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

Question

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

Unprotect VBProject from VB code

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

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

在尝试处理那里的信息时，我发现如果不运行另一个 Excel 实例，我无法获得 VBA 项目属性对话框窗口的窗口句柄 hWnd...

我的问题是：

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

2.为什么不运行第二个 Excel 实例就无法获得 VBA 项目属性对话框窗口的 hWnd？

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

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