使用Win32 API解锁Excel VBProject时避免主VBE挂起的方案问询

解决方案 #

根本原因 #

你当前调用的SendMessage是同步Win32 API，调用后会一直阻塞等待目标窗口处理完消息并返回结果，才会执行后续代码。当输入密码错误时，目标Excel实例弹出的「Project Locked」是模态对话框，会阻塞目标进程的消息循环，导致SendMessage一直无法返回，主Excel实例的VBA自然就挂起了。

可行修改方案 #

完全不需要引入第三个实例，也不需要使用SendKeys，仅需修改2处代码即可解决问题：

1. 新增PostMessage API声明
   在你现有代码的API声明块中新增异步消息发送API的声明：

#If VBA7 Then
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
#Else
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If

PostMessage是异步API，消息发送后会立刻返回，不会等待目标窗口的处理结果，不会阻塞主实例VBA的执行。
2. 替换点击OK按钮的API调用
把你原来点击密码窗口OK按钮的代码：

SendMessage OKRet, BM_CLICK, 0, vbNullString

替换为：

PostMessage OKRet, BM_CLICK, 0, vbNullString

后续自动检测逻辑补充 #

因为是异步调用，发完消息后需要加一段短时间的循环检测逻辑，判断密码是否正确，或者错误弹窗是否弹出：

' 点击OK后最多等待2秒检测结果
Dim startTime As Single: startTime = Timer
Dim pwdValid As Boolean: pwdValid = False
Dim errWindowFound As Boolean: errWindowFound = False

Do While Timer - startTime < 2
    DoEvents
    ' 检测是否弹出项目属性窗口（密码正确）
    Ret = FindWindow(vbNullString, vbProj.Name & " - Project Properties")
    If Ret <> 0 Then
        pwdValid = True
        Exit Do
    End If
    ' 检测是否弹出密码错误窗口（密码错误）
    Ret = FindWindow(vbNullString, "Project Locked")
    If Ret <> 0 Then
        errWindowFound = True
        Exit Do
    End If
Loop

' 密码错误的处理逻辑
If errWindowFound Then
    ' 点击错误窗口的OK按钮
    Dim ok3Ret As LongPtr ' 32位系统请改为Long
    ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
    Do While ChildRet <> 0
        strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
        GetWindowText ChildRet, strBuff, Len(strBuff)
        If InStr(1, strBuff, "OK") Then
            ok3Ret = ChildRet
            Exit Do
        End If
        ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
    Loop
    If ok3Ret <> 0 Then
        PostMessage ok3Ret, BM_CLICK, 0, vbNullString
        DoEvents
        ' 再关闭密码输入窗口，即可尝试下一个密码
        Ret = FindWindow(vbNullString, vbProj.Name & " Password")
        If Ret <> 0 Then
            Dim cancelRet As LongPtr ' 32位系统请改为Long
            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
            Do While ChildRet <> 0
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                If InStr(1, strBuff, "Cancel") Then
                    cancelRet = ChildRet
                    Exit Do
                End If
                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
            Loop
            If cancelRet <> 0 Then
                PostMessage cancelRet, BM_CLICK, 0, vbNullString
                DoEvents
            End If
        End If
    End If
End If

这个方案完全避免使用SendKeys，也不需要额外的Excel实例，符合你的所有需求。

内容的提问来源于stack exchange，提问作者hymced