在新的Excel实例中捕获已打开的工作簿

时间:2016-10-10 17:26:44

标签: excel vba excel-vba

我有一些宏,我希望它运行一些代码,然后提示用户从另一个程序导出Excel工作簿,然后在打开导出后运行更多代码。棘手的部分是某些程序导出到新的Excel实例,而其他程序导出到当前实例。

目前的工作流程是(底层代码):

  1. 使用导出名称调用中央“捕获”模块(有些 程序导出'书[x]'有些做'工作簿[x]'等)和 找到导出后要运行的过程。

  2. Capture Module获取所有现有工作簿名称的列表 Excel实例并另存为模块级字符串。

  3. Capture Module使用Application.OnTime使其每隔3秒就可以了 扫描所有Excel实例中的所有工作簿列表。

  4. 如果找到的工作簿不在之前保存的列表中 所有现有工作簿名称,并包含该名称 export,它将该工作簿存储为公共模块级变量, 并运行步骤1中保存的过程,可以参考 商店工作簿。

  5. 这适用于所有情况, EXCEPT 。如果我已经在我当前的Excel实例中打开了Book1.xlsx,并且第三方程序将Book1.xlsx导出到Excel的新实例,则程序不会将此识别为导出,因为Book1.xlsx位于现有的工作簿名称字符串数组已经。

    我的解决方案是找到一种唯一识别每个工作簿的方法,这些工作簿优于“名称”或“路径”。我尝试将现有工作簿名称字符串中的每个工作簿名称保存为[application.hwnd]![工作簿名称],但这是一个不稳定的修复程序并经常破坏(我真的不明白hwnd如何工作所以我不能说为什么)

    有什么想法吗?谢谢!

    使用MCaptureExport的示例程序

    Public Sub GrabFXAllExport()
    
        Const sSOURCE As String = "GrabFXAllExport"
    
        On Error GoTo ErrorHandler
    
        If Not TAAA.MCaptureExport.bCaptureExport("FXALL", "TAAA.FXAllEmail.ProcessFXAllExport") Then Err.Raise glHANDLED_ERROR
    
    ErrorExit:
    
        Exit Sub
    
    ErrorHandler:
        If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Sub
    Public Sub ProcessFXAllExport()
    
        Const sSOURCE As String = "ProcessFXAllExport"
    
        On Error GoTo ErrorHandler
    
        If MCaptureExport.mwbCaptured Is Nothing Then
            MsgBox "Exported Workbook Not Found. Please try again.", vbCritical, gsAPP_NAME
            GoTo ErrorExit
        End If
    
        Dim wsSourceSheet As Worksheet
        Set wsSourceSheet = MCaptureExport.mwbCaptured.Worksheets(1)
        Set MCaptureExport.mwbCaptured = Nothing
    
        [I now have the export and can work with it as a I please]
    
    ErrorExit:
    
        Exit Sub
    
    ErrorHandler:
        If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Sub
    

    MCaptureExport模块

    Option Explicit
    Option Base 1
    
    ' Description:  This module contains the central error
    '               handler and related constant declarations.
    Private Const msMODULE As String = "MCaptureExport"
    
    Private sExistingWorkbookList() As String
    Public mwbCaptured As Workbook
    Public msCaptureType As String
    Private sReturnProcedure As String
    Private bListening As Boolean
    Public Function bCaptureExport(sCaptureType As String, sRunAfterCapture As String) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bCaptureExport()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        If Not bWorkbookNamesAsArray(sExistingWorkbookList, True, False) Then Err.Raise glHANDLED_ERROR
    
        sReturnProcedure = sRunAfterCapture
        bListening = True
        msCaptureType = sCaptureType
        TAAA.MCaptureExport.WaitForCapture sCaptureTypeToNameContains(msCaptureType)
        MsgBox "Waiting for " & msCaptureType & " Export", vbInformation, gsAPP_NAME
    
    ErrorExit:
    
        bCaptureExport = bReturn
        Exit Function
    
    ErrorHandler:
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Function
    
    Private Sub WaitForCapture(sNameContains As String)
    
        Const sSOURCE As String = "WaitForCapture"
    
        On Error GoTo ErrorHandler
    
        Dim wbCaptureCheck As Workbook
        If Not bCaptureCheck(sNameContains, wbCaptureCheck) Then Err.Raise glHANDLED_ERROR
    
        If wbCaptureCheck Is Nothing Then
            If bListening Then _
                Application.OnTime Now + TimeSerial(0, 0, 3), "'TAAA.MCaptureExport.WaitForCapture " & Chr(34) & sNameContains & Chr(34) & "'"
        Else
            Dim bSameApp As Boolean
            If Not bWorkbooksInSameApp(ThisWorkbook, wbCaptureCheck, bSameApp) Then Err.Raise glHANDLED_ERROR
    
            If Not bSameApp Then
                Dim sTempFilePath As String
                sTempFilePath = ThisWorkbook.Path & "\temp_" & Format(Now, "mmddyyhhmmss") & ".xls"
                wbCaptureCheck.SaveCopyAs sTempFilePath
                wbCaptureCheck.Close SaveChanges:=False
                Set wbCaptureCheck = Application.Workbooks.Open(sTempFilePath)
            End If
    
            Set mwbCaptured = wbCaptureCheck
            bListening = False
            Application.Run sReturnProcedure
        End If
    
    ErrorExit:
    
        Exit Sub
    
    ErrorHandler:
        If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Sub
    Private Function sCaptureTypeToNameContains(sCaptureType As String) As String
    
        sCaptureTypeToNameContains = "*"
    
        On Error Resume Next
    
        Select Case UCase(sCaptureType)
            Case "SOTER": sCaptureTypeToNameContains = "workbook"
            Case "THOR": sCaptureTypeToNameContains = "Book"
            Case "FXALL": sCaptureTypeToNameContains = "search_results_export"
        End Select
    
    End Function
    Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bCaptureCheck()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        Dim i As Long, wb As Workbook
        Dim xlApps() As Application
        If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
        For i = LBound(xlApps) To UBound(xlApps)
            For Each wb In xlApps(i).Workbooks
    
                If wb.Name Like "*" & sNameContains & "*" _
                    And Not bIsInArray(wb.Name, sExistingWorkbookList) Then
    
                    Set wbResult = wb
                    GoTo ErrorExit
    
                End If
            Next
        Next
    
    ErrorExit:
    
        bCaptureCheck = bReturn
        Exit Function
    
    ErrorHandler:
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Function
    

    MCaptureExport使用的实用程序函数

    Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bWorkbookNamesAsArray()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        Dim i As Long, wb As Workbook
        Dim xlApps() As Application
    
        Dim ResultArray() As String
        Dim Ndx As Integer, wbCount As Integer
    
        If bAllInstances Then
            If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
        Else
            ReDim xlApps(0)
            Set xlApps(0) = Application
        End If
    
        For i = LBound(xlApps) To UBound(xlApps)
            For Each wb In xlApps(i).Workbooks
                wbCount = wbCount + 1
            Next
        Next
    
        ReDim ResultArray(1 To wbCount)
    
        For i = LBound(xlApps) To UBound(xlApps)
            For Each wb In xlApps(i).Workbooks
                Ndx = Ndx + 1
                ResultArray(Ndx) = wb.Name
            Next
        Next
    
        sResult = ResultArray()
    
    ErrorExit:
    
        bWorkbookNamesAsArray = bReturn
        Exit Function
    
    ErrorHandler:
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    
    End Function
    Public Function bGetAllExcelInstances(xlApps() As Application) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bGetAllExcelInstances()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        Dim n As Long
    
        Dim hWndMain As LongPtr
    
        Dim app As Application
    
        ' Cater for 100 potential Excel instances, clearly could be better
        ReDim xlApps(1 To 100)
    
        hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
    
        Do While hWndMain <> 0
            If Not bGetExcelObjectFromHwnd(hWndMain, app) Then Err.Raise glHANDLED_ERROR
    
            If Not (app Is Nothing) Then
                If n = 0 Then
                    n = n + 1
                    Set xlApps(n) = app
                ElseIf bCheckHwnds(xlApps, app.Hwnd) Then
                    n = n + 1
                    Set xlApps(n) = app
                End If
            End If
            hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    
        Loop
    
        If n Then
            ReDim Preserve xlApps(1 To n)
            'GetAllExcelInstances = n
        Else
            Erase xlApps
        End If
    
    ErrorExit:
    
        bGetAllExcelInstances = bReturn
        Exit Function
    
    ErrorHandler:
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Function
    
    
    Private Function bCheckHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
    
        On Error Resume Next
    
        Dim i As Integer
    
        For i = LBound(xlApps) To UBound(xlApps)
            If Not xlApps(i) Is Nothing Then
                If xlApps(i).Hwnd = Hwnd Then
                    bCheckHwnds = False
                    Exit Function
                End If
            End If
        Next i
    
        bCheckHwnds = True
    
    End Function
    Public Function bWorkbooksInSameApp(wb1 As Workbook, wb2 As Workbook, bSameApp As Boolean) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bWorkbooksInSameApp()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        bSameApp = wb1.Application.Hwnd = wb2.Application.Hwnd
    
    ErrorExit:
    
        bWorkbooksInSameApp = bReturn
        Exit Function
    
    ErrorHandler:
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    
    End Function
    Private Function bGetExcelObjectFromHwnd(ByVal hWndMain As LongPtr, aAppResult As Application) As Boolean
    
        Dim bReturn As Boolean
        Const sSOURCE As String = "bGetExcelObjectFromHwnd()"
    
        On Error GoTo ErrorHandler
        bReturn = True
    
        Dim hWndDesk As LongPtr
        Dim Hwnd As LongPtr
        Dim strText As String
        Dim lngRet As Long
        Dim iid As UUID
        Dim obj As Object
    
        hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
    
        If hWndDesk <> 0 Then
    
            Hwnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
    
            Do While Hwnd <> 0
    
            strText = String$(100, Chr$(0))
            lngRet = CLng(GetClassName(Hwnd, strText, 100))
    
            If Left$(strText, lngRet) = "EXCEL7" Then
    
                Call IIDFromString(StrPtr(IID_IDispatch), iid)
    
                If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
    
                    Set aAppResult = obj.Application
                    GoTo ErrorExit
    
                End If
    
            End If
    
            Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
            Loop
    
        End If
    
    ErrorExit:
    
        bGetExcelObjectFromHwnd = bReturn
        Exit Function
    
    ErrorHandler:
        MsgBox Err.Number
        bReturn = False
        If bCentralErrorHandler(msMODULE, sSOURCE) Then
            Stop
            Resume
        Else
            Resume ErrorExit
        End If
    
    End Function
    

1 个答案:

答案 0 :(得分:1)

我有一个潜在的解决方案。但是我想把这个问题保持开放。这是一个相当复杂的问题,我敢打赌,有比我提出的更优雅的解决方案。

所以我将sExistingWorkbookList的格式更新为[Application.hWnd]![Workbook.name]。我之前尝试过这个,但我觉得这次工作正常。

思想?

更新版本的bWorkbookNamesAsArray

wb.Application.Hwnd & "!" &添加到ResultArray(Ndx) = wb.name

Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bWorkbookNamesAsArray()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook
    Dim xlApps() As Application

    Dim ResultArray() As String
    Dim Ndx As Integer, wbCount As Integer

    If bAllInstances Then
        If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    Else
        ReDim xlApps(0)
        Set xlApps(0) = Application
    End If

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            wbCount = wbCount + 1
        Next
    Next

    ReDim ResultArray(1 To wbCount)

    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks
            Ndx = Ndx + 1
            ResultArray(Ndx) = wb.Application.Hwnd & "!" & wb.Name
        Next
    Next

    sResult = ResultArray()

ErrorExit:

    bWorkbookNamesAsArray = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function

新效用函数

Public Function bGetWorkbookFromHwndAndName(ByVal sWorkbookReference As String, ByRef wbResult As Workbook)

    Dim bReturn As Boolean
    Const sSOURCE As String = "bGetWorkbookFromHwndAndName()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim xlApp As Application

    If Not bGetExcelObjectFromHwnd(CLng(Split(sWorkbookReference, "!")(0)), xlApp) Then Err.Raise glHANDLED_ERROR

    Set wbResult = xlApp.Workbooks(Split(sWorkbookReference, "!")(1))

ErrorExit:

    bGetWorkbookFromHwndAndName = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function

更新了MCaptureExport.bCaptureCheck()

    Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean

    Dim bReturn As Boolean
    Const sSOURCE As String = "bCaptureCheck()"

    On Error GoTo ErrorHandler
    bReturn = True

    Dim i As Long, wb As Workbook, sFullWorkbookReference As String
    Dim xlApps() As Application
    If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
    For i = LBound(xlApps) To UBound(xlApps)
        For Each wb In xlApps(i).Workbooks

            sFullWorkbookReference = wb.Application.Hwnd & "!" & wb.Name

            If wb.Name Like "*" & sNameContains & "*" _
                And Not bIsInArray(sFullWorkbookReference, sExistingWorkbookList) Then

                If Not bGetWorkbookFromHwndAndName(sFullWorkbookReference, wbResult) Then Err.Raise glHANDLED_ERROR
                GoTo ErrorExit

            End If
        Next
    Next

ErrorExit:

    bCaptureCheck = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msMODULE, sSOURCE) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Function