Question

我需要帮助来获取VBA项目属性对话框的hWnd。我正在努力学习VBA并对VBE编程很感兴趣。我阅读并成功测试了以下链接中的说明：

http://www.siddharthrout.com/2013/04/24/unprotecting-vba-project-password-using-a-password-that-you-know/

在进一步阅读以下链接后：

http://www.standards.com/Office/SetVBAProjectPassword.html

并且在尝试使用那里的信息时，我发现我无法在不运行另一个Excel实例的情况下获得VBA项目属性对话框窗口的窗口句柄...

我的问题是：

1.如何获取当前运行的Excel实例的VBA项目属性对话框窗口？

2.为什么我不能在不运行第二个Excel实例的情况下获得VBA项目属性对话框窗口？

我还附上了我复制和编辑的代码，如下所示。这是我的第一个问题，所以请原谅我有任何格式问题，如果有人发现这篇文章不遵守论坛规则，请告诉我。我已经准备好纠正它了。我已经搜索了论坛的帖子，但只发现了最不相关的主题，这些主题无法完全解决我的问题。提前谢谢。

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetActiveWindow Lib "user32.dll" () As Long

Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String

Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5

'ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3

Sub test1()
Dim hWndOfProjectPropertiesOfThisProject As Long
    ThisWorkbook.VBProject.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True, Visible:=False).Execute
    'hWndOfProjectPropertiesOfThisProject = GetActiveWindow
    'Debug.Print hWndOfProjectPropertiesOfThisProject
    GethWndOfProjectPropertiesWindow
End Sub

Sub test2()
    OpenANewExcel
    GethWndOfProjectPropertiesWindow
End Sub

Sub OpenANewExcel()
Dim xlAp As Object, oWb As Object, sWb As Object
Dim strpath As String

    Set xlAp = CreateObject("Excel.Application")
    xlAp.Visible = True

    strpath = ThisWorkbook.Path + "\" + ThisWorkbook.Name
    Set oWb = xlAp.Workbooks.Open(strpath)
    oWb.Activate
    xlAp.Parent.Windows(1).Visible = True
    xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True, Visible:=False).Execute
End Sub

Sub GethWndOfProjectPropertiesWindow()
    Dim hWndProjectProperties As Long
    hWndProjectProperties = FindWindow(vbNullString, "VBAProject - Project Properties")
    Debug.Print "hWnd = " & hWndProjectProperties
End Sub

我还阅读了cpearson.com/excel/vbe.aspx（不能发布超过2个链接）

Answer 1

以下是使用计时器的示例。我无法保证这将可靠地工作。我在过去纯粹作为理论测试使用过它，但它起作用，但我记得在所有Excel版本或操作系统选项中从未100％可靠。（因为我从来没有使用过这样的代码，我从来没有进一步追求它）

Option Explicit
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
                              ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
                              ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
                           ByVal hWnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
                            ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
                             ByVal hWnd As Long, ByVal uMsg As Long, _
                             ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
                             ByVal hWnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const WM_CLOSE = &H10
Public Const WM_GETTEXT = &HD
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&
  Const IDTab = &H3020&
  Const IDLockProject = &H1557&
  Const IDPassword = &H155E&
  Const IDConfirmPassword = &H1556&
  Const IDOK = &H1&

Private Const TimeoutSecond = 2

Private g_ProjectName    As String
Private g_Password       As String
Private g_hwndVBE        As Long
Private g_Result         As Long
Private g_hwndPassword   As Long


Public Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                                ByVal idEvent As Long, ByVal dwTime As Long) As Long
   Dim hwndProjectProp As Long, hwndProjectProp2 As Long
   Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
   Dim hwndConfirmPassword As Long, hwndOK As Long
   Dim hWndTmp As Long, lRet As Long
   Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
   Dim IDConfirmPassword As Long, IDOK As Long
   Dim sCaption          As String
   Dim timeout As Date, timeout2 As Date
   Dim pwd               As String

   On Error GoTo ErrorHandler
   KillTimer 0, idEvent
   sCaption = " Password"

   'for the japanese version
   Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
      Case 1041
         sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
                    ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
                    ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
                    ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
   End Select

   sCaption = g_ProjectName & sCaption
   timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
   Do While Now() < timeout

      hwndPassword = 0
      hwndOK = 0

      hWndTmp = 0
      Do
         hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
         If hWndTmp = 0 Then Exit Do
      Loop Until GetParent(hWndTmp) = g_hwndVBE
      If hWndTmp = 0 Then GoTo Continue
      Debug.Print "found window"
      lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

      hwndPassword = GetDlgItem(hWndTmp, IDPassword)
      Debug.Print "hwndpassword: " & hwndPassword

      hwndOK = GetDlgItem(hWndTmp, IDOK)
      Debug.Print "hwndOK: " & hwndOK

      If (hWndTmp _
          And hwndOK) = 0 Then GoTo Continue

      lRet = SetFocusAPI(hwndPassword)
      lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
      lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)

      pwd = String(260, Chr(0))
      lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
      pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
      If pwd <> g_Password Then GoTo Continue
    lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)

      lRet = SetFocusAPI(hwndOK)
      lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

      g_Result = 1
      Exit Do

Continue:
      DoEvents
      Sleep 100
   Loop
       Exit Function

ErrorHandler:
   If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
   LockWindowUpdate 0
End Function



Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
    Dim timeout               As Date
    Dim lRet                  As Long

    On Error GoTo ErrorHandler
    UnlockProject = 1
    If Project.Protection <> vbext_pp_locked Then
        UnlockProject = 2
        Exit Function
    End If

    g_ProjectName = Project.Name
    g_Password = Password
    '    LockWindowUpdate GetDesktopWindow()
    Application.VBE.MainWindow.visible = True
    g_hwndVBE = Application.VBE.MainWindow.hWnd
    g_Result = 0
    lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
    If lRet = 0 Then
        Debug.Print "error setting timer"
        GoTo ErrorHandler
    End If
    Set Application.VBE.ActiveVBProject = Project
    If Not Application.VBE.ActiveVBProject Is Project Then
        GoTo ErrorHandler
    End If
    Application.VBE.CommandBars.FindControl(ID:=2578).Execute

    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While g_Result = 0 And Now() < timeout
        DoEvents
    Loop
    If g_Result Then
        UnlockProject = 0
    End If

    AppActivate Application.Caption
    LockWindowUpdate 0
    Exit Function

ErrorHandler:
    AppActivate Application.Caption
    LockWindowUpdate 0
End Function

Sub Test_UnlockProject()
   Select Case UnlockProject(ActiveWorkbook.VBProject, "test")
      Case 0: MsgBox "The project was unlocked."
      Case 2: MsgBox "The active project was already unlocked."
      Case Else: MsgBox "Error or timeout."
   End Select
End Sub

Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, _
                                ByVal idEvent As Long, ByVal dwTime As Long) As Long
   Dim timeout As Date
   Dim hWndTmp As Long
   Dim hwndOK As Long
   Dim lRet As Long
   Dim sCaption As String


   sCaption = g_ProjectName & " - Project Properties"
    Debug.Print sCaption

    On Error GoTo ErrorHandler
   KillTimer 0, idEvent

   timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
   Do While Now() < timeout

      hWndTmp = 0
      Do
         hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
         If hWndTmp = 0 Then Exit Do
      Loop Until GetParent(hWndTmp) = g_hwndVBE
      If hWndTmp = 0 Then GoTo Continue
      Debug.Print "found properties window"
      lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

      hwndOK = GetDlgItem(hWndTmp, IDOK)
      Debug.Print "hwndOK: " & hwndOK
      If (hWndTmp _
          And hwndOK) = 0 Then GoTo Continue

      lRet = SetFocusAPI(hwndOK)
      lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

      g_Result = 1
      Exit Do

Continue:
      DoEvents
      Sleep 100
   Loop
    Exit Function

ErrorHandler:
    Debug.Print Err.Number
   LockWindowUpdate 0
End Function

获取VBA项目属性对话框窗口的hWnd

1 个答案: