在新的Excel實例中捕獲打開的工作簿

我有一些宏需要它運行一些代碼，然後提示用戶從另一個程序中導出Excel工作簿，然後在導出打開後運行更多代碼。棘手的部分是某些程序導出到Excel的新實例，而其他程序導出到當前實例。在新的Excel實例中捕獲打開的工作簿

當前工作流程（在底部代碼）：

呼叫中心「捕獲」模塊與所述出口的名稱（一些程序導出「書[X]」一些做「工作簿[ x]'等）以及您希望在找到導出後運行的過程。
Capture Module從所有 Excel實例中獲取所有現有工作簿名稱的列表，並將其保存爲模塊級字符串。
Capture Module使用Application.OnTime，以便每隔3秒掃描所有Excel實例中所有工作簿的列表。
如果找到一個工作簿，是不是在所有現有的工作簿名先前保存的列表，包含出口的名稱，它存儲工作簿作爲公共模塊級變量，並運行從步驟1中保存的程序，其可以參考商店工作簿。

這工作得很好在所有情況下，除非爲一個。如果我已在當前的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

使用

來源

2016-10-10 Mike K

很難處理這樣的進程外的東西，有沒有一種方法，而不是你可以提示用戶導出/保存爲輸出Excel文件？然後您只需要一個FileDialog並提示用戶從另一個應用程序中選擇（導出）文件。 –

應該起作用的一個想法是，不是緩存打開的工作簿名稱列表，而是爲每個工作簿分配一個'CustomDocumentProperty'，您可以合理確保在導出的XLSX文件中不存在'CustomDocumentProperty'。然後，您可以簡單地掃描文件（按名稱）的應用程序/工作簿，該文件沒有**屬性。 –

@DavidZemens這是一個有趣的想法！如果我的hWnd下面的解決方案不起作用，我會在下一次嘗試你的。非常感謝你的幫助！ –

我有一個潛在的解決方案。不過，我想留下這個問題。這是一個相當複雜的問題，我敢打賭，有比我提出的更優雅的解決方案。

因此，我將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

來源

2016-10-10 18:24:17

在新的Excel實例中捕獲打開的工作簿

回答

相關問題