VBA-解决模态窗口程序挂起问题

解决网页模态窗口导致VBA程序等待的问题。主要思路就是在弹窗前用VBA创建一个VBS，通过VBS调用此excel中的宏或者直接由VBS处理弹窗。实践中发现office会把这种操作检测为病毒?…..但是WPS是可以正常使用。示例代码见下：

' 需要引用: "Microsoft HTML Object Library"

'模拟鼠标点击，用来模拟点击窗口使窗口激活并获得焦点（不是必须的）
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Const MOUSEEVENTF_MOVE = &H1
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN = &H8
Public Const MOUSEEVENTF_RIGHTUP = &H10
Public Const MOUSEEVENTF_MIDDLEDOWN = &H20
Public Const MOUSEEVENTF_MIDDLEUP = &H40
Public Const MOUSEEVENTF_ABSOLUTE = &H8000
Type POINTAPI
    x As Long
    y As Long
End Type

'用于前置窗口，以便鼠标点击（不是必须的）
Private Declare Function SetWindowPos Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long) As Long

Private Const SMTO_ABORTIFHUNG = &H2
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function ShowWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName 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 GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long

Private Declare Function IsWindowVisible Lib "user32" _
    (ByVal hwnd As Long) As Boolean

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
    (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Function RegisterWindowMessage Lib "user32" _
     Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
     
Private Declare Function EnumChildWindows Lib "user32" _
    (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, lParam As Long) As Long

Private Declare Function SendMessageTimeout Lib "user32" _
    Alias "SendMessageTimeoutA" ( _
    ByVal hwnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    lParam As Any, _
    ByVal fuFlags As Long, _
    ByVal uTimeout As Long, _
    lpdwResult As Long) As Long

Private Declare Function ObjectFromLresult Lib "oleacc" ( _
    ByVal lResult As Long, _
    riid As GUID, _
    ByVal wParam As Long, _
    ppvObject As Any) As Long

'Given an IE dialog window title, find the window and return a reference
'   to the embedded HTML document object
Function GetIEDialogDocument(dialogTitle As String) As IHTMLDocument
    Dim lhWndP As Long, lhWndC As Long, doc As IHTMLDocument
    'find the IE dialog window given its title
    If GetHandleFromPartialCaption(lhWndP, dialogTitle) Then
        Debug.Print "Found dialog window - " & dialogTitle & "(" & TheClassName(lhWndP) & ")"
        Debug.Print , "getting the document..."
        Set doc = IEDOMFromhWnd(lhWndP)
        
        '让子窗口前端显示,如果子窗口可以前端显示下面的内容就没有必要
        Const HWND_TOPMOST = -1
        Const HWND_NOTOPMOST = -2
        Const SWP_NOMOVE = &H2
        Const SWP_NOSIZE = &H1
        Const SWP_NOZORDER = &H4
        Const SWP_NOACTIVATE = &H10
        Const SWP_SHOWWINDOW = &H40
        Const SWP_HIDEWINDOW = &H80
        Const SWP_ASYNCWINDOWPOS = &H4000
        '设置窗口位置
        posX = 600
        posY = 300
        '最前端显示
        SetWindowPos lhWndP, HWND_TOPMOST, posX, posY, 0, 0, SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_ASYNCWINDOWPOS
        '模拟鼠标点击页面
        Dim Cp As POINTAPI
        GetCursorPos Cp
        SetCursorPos posX, posY
        mouse_event &H2, 0, 0, 0, 0
        mouse_event &H4, 0, 0, 0, 0
        
        '取消前端显示，取消激活
        SetWindowPos lhWndP, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE  
    Else
        Debug.Print "Window '" & dialogTitle & "' not found!"
    End If
    Set GetIEDialogDocument = doc 
End Function

' 函数：IEDOMFromhWnd。
'
' 返回：一个 WebBrowser 窗口的 IHTMLDocument 对象接口。
'
' hWnd 参数：WebBrowser 控件的句柄或 WebBrowser 控件所在窗口的句柄。
'
Function IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument
    Dim IID_IHTMLDocument As GUID
    Dim hWndChild As Long
    Dim lRes As Long
    Dim lMsg As Long
    Dim hr As Long
    
    If hwnd <> 0 Then
        If Not IsIEServerWindow(hwnd) Then
            ' 查找一个 WebBrowser 控件。
            EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd
        End If
        ' 注册消息。
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        ' 获取对象的指针。
        Call SendMessageTimeout(hwnd, lMsg, 0, 0, _
        SMTO_ABORTIFHUNG, 1000, lRes)
        If lRes Then
            ' 初始化接口 ID。
            With IID_IHTMLDocument
                .Data1 = &H626FC520
                .Data2 = &HA41E
                .Data3 = &H11CF
                .Data4(0) = &HA7
                .Data4(1) = &H31
                .Data4(2) = &H0
                .Data4(3) = &HA0
                .Data4(4) = &HC9
                .Data4(5) = &H8
                .Data4(6) = &H26
                .Data4(7) = &H37
            End With
            ' 利用指针 lRes 获取 IHTMLDocument 对象。
            hr = ObjectFromLresult(lRes, IID_IHTMLDocument, 0, IEDOMFromhWnd)
        End If
    End If
End Function

'utilty function for getting the classname given a window handle
Function TheClassName(lhWnd As Long)
    Dim strText As String, lngRet As Long
    strText = String$(100, Chr$(0))
    lngRet = GetClassName(lhWnd, strText, 100)
    TheClassName = Left$(strText, lngRet)
End Function

Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, _
                                             ByVal sCaption As String) As Boolean
    Dim lhWndP As Long, sStr As String

    GetHandleFromPartialCaption = False
    lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
    Do While lhWndP <> 0
        sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
        GetWindowText lhWndP, sStr, Len(sStr)
        sStr = Left$(sStr, Len(sStr) - 1)
        If Len(sStr) > 2 Then
            If UCase(sStr) Like "*ARG*" Then Debug.Print sStr
        End If
        If InStr(1, sStr, sCaption) > 0 Then
            GetHandleFromPartialCaption = True
            lWnd = lhWndP
            Exit Do
        End If
        lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
    Loop
End Function

Private Function IsIEServerWindow(ByVal hwnd As Long) As Boolean
    Dim lRes As Long
    Dim sClassName As String
    ' 初始化缓冲区大小。
    sClassName = String$(255, 0)
    ' 获取 hWnd 句柄拥有者的类名称。
    lRes = GetClassName(hwnd, sClassName, Len(sClassName))
    sClassName = Left$(sClassName, lRes)
    IsIEServerWindow = StrComp(sClassName, _
    "Internet Explorer_Server", _
    vbTextCompare) = 0
End Function

Function EnumChildProc(ByVal hwnd As Long, lParam As Long) As Long
    If IsIEServerWindow(hwnd) Then
        lParam = hwnd
    Else
        EnumChildProc = 1
    End If
End Function

'通过创建vbs来运行表格里面的宏，用于解决网页模态窗口导致宏暂停问题
Private Sub vbsRunMacro(xlFullName As String, xlMacroName As String, parameter As String)
    Dim vbsFullName As String, res As String
    vbsFullName = Environ("temp") & "\temp.vbs"
    Open vbsFullName For Output As #1
    Print #1, "Set xlApp = GetObject(, ""Excel.Application"")" 'GetObject直接调用已经打开的thisworkbook里的宏
    Print #1, "xlApp.Visible = True"
    Print #1, "For Each xlBook In xlApp.Workbooks"
    Print #1, "If xlBook.FullName = """ & xlFullName & """ Then"
    Print #1, "Set oWorkbooks = xlBook"
    Print #1, "xlApp.Run """ & xlMacroName & """, """ & parameter & """" '根据需要调整宏的名称"
'    Print #1, "xlApp.Quit"
    Print #1, "End If"
    Print #1, "Next"
    Print #1, "Set oWorkbooks= nothing"
    Print #1, "Set xlApp= nothing"
    Close #1
'    ShellAndWait vbsFullName
    Shell "wscript.exe " & vbsFullName
    
'    '延时等待bat执行后删除文件
    Application.Wait (Now + TimeValue("0:00:01"))
    Kill vbsFullName
End Sub

'通过创建vbs来发送按键，用于解决网页alert窗口导致宏暂停问题
'解决ASP.net从服务器端向客户端弹出alert对话框，这类弹窗无法通过重写js alert来处理
Private Sub vbsSendKeys(oKeys As String)
    Dim vbsFullName As String
    vbsFullName = Environ("temp") & "\temp.vbs"
    Open vbsFullName For Output As #1
    Print #1, "set wshshell = createobject(""wscript.shell"")"
    Print #1, "wscript.sleep 3500"
    Print #1, "wshshell.sendkeys " & oKeys
    Print #1, "Set wshshell= nothing"
    Close #1
'    ShellAndWait vbsFullName
    Shell "wscript.exe " & vbsFullName
    
    '延时等待bat执行后删除文件
    Application.Wait (Now + TimeValue("0:00:01"))
    Kill vbsFullName
End Sub

Private Sub DialogPerson(vendor_person As String)
    Const DLG_TITLE = "窗口title" '<< the dialog title
    Dim doc As IHTMLDocument
    
    Application.Wait (Now + TimeValue("0:00:01")) '等待弹窗
    Set doc = GetIEDialogDocument(DLG_TITLE)

    If Not doc Is Nothing Then
        doc.getElementById("txtName").Value = vendor_person '<<填写子页面弹窗内的表单
        ......
        vbsSendKeys """{enter}""" '调用vbs发送回车键关闭子窗口的alert弹窗
        doc.getElementById("btnSave").Click '点击按钮，调出alert弹窗
    Else
        Debug.Print "Dialog Window '" & DLG_TITLE & "' was not found!", vbOKOnly + vbExclamation
    End If
    Set doc = Nothing
End Sub

'填写表单的程序
Private Sub enterPage(vendor_person As String, ...)
    myURL = "http://...."
    With CreateObject("internetexplorer.application")
        .Visible = True
        .navigate myURL
        Do Until .readyState = 4: DoEvents: Loop
        Application.Wait (Now + TimeValue("0:00:01")) '等待确保页面完全打开
        vbsRunMacro ThisWorkbook.FullName, "DialogPerson", vendor_person '调用vbs打开子页面弹窗
        ......
        End With      
    End With    
End Sub

’主程序
Sub main()
    enterPage Cells(i, "A")...
End Sub