VBA可以跨多個Excel實例到達嗎？

Question

在一個Excel實例中運行的Excel VBA宏是否可以訪問在另一個Excel實例中運行的工作簿？ 例如，我想創建一個在任何正在運行的Excel實例中打開的所有工作簿的列表。

Answer 1

科尼利厄斯的回答部分正確。 他的代碼獲取當前實例，然后創建一個新實例。 無論有多少實例可用， GetObject都只會獲得第一個實例。 我相信的問題是，如何從許多實例中獲取特定實例。

對於VBA項目，使用一個名為Command1的命令按鈕，將兩個模塊（一個代碼模塊）和另一個模塊制成表單。 您可能需要添加對Microsoft.Excel的引用。

此代碼在“即時”窗口中顯示每個正在運行的Excel實例的每個工作簿的所有名稱。

'------------- Code Module --------------

Option Explicit

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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

Type UUID 'GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

'------------- Form Module --------------

Option Explicit

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

'Sub GetAllWorkbookWindowNames()
Sub Command1_Click()
    On Error GoTo MyErrorHandler

    Dim hWndMain As Long
    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        GetWbkWindows hWndMain
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    Exit Sub

MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Private Sub GetWbkWindows(ByVal hWndMain As Long)
    On Error GoTo MyErrorHandler

    Dim hWndDesk As Long
    hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

    If hWndDesk <> 0 Then
        Dim hWnd As Long
        hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

        Dim strText As String
        Dim lngRet As Long
        Do While hWnd <> 0
            strText = String$(100, Chr$(0))
            lngRet = GetClassName(hWnd, strText, 100)

            If Left$(strText, lngRet) = "EXCEL7" Then
                GetExcelObjectFromHwnd hWnd
                Exit Sub
            End If

            hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
            Loop

        On Error Resume Next
    End If

    Exit Sub

MyErrorHandler:
    MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
    On Error GoTo MyErrorHandler

    Dim fOk As Boolean
    fOk = False

    Dim iid As UUID
    Call IIDFromString(StrPtr(IID_IDispatch), iid)

    Dim obj As Object
    If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
        Dim objApp As Excel.Application
        Set objApp = obj.Application
        Debug.Print objApp.Workbooks(1).Name

        Dim myWorksheet As Worksheet
        For Each myWorksheet In objApp.Workbooks(1).Worksheets
            Debug.Print "     " & myWorksheet.Name
            DoEvents
        Next

        fOk = True
    End If

    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

Answer 2

我相信VBA比Charles認為的要強大;）

如果只有一些棘手的方法可以從GetObject和CreateObject指向特定實例，那么我們將為您解決問題！

編輯：

如果您是所有實例的創建者，那么列出工作簿之類的東西就不會有問題。 看一下這段代碼：

Sub Excels()
    Dim currentExcel As Excel.Application
    Dim newExcel As Excel.Application

    Set currentExcel = GetObject(, "excel.application")
    Set newExcel = CreateObject("excel.application")

    newExcel.Visible = True
    newExcel.Workbooks.Add
    'and so on...
End Sub

Answer 3

我認為在VBA中，您可以訪問另一個正在運行的實例中的應用程序對象 。 如果您知道在另一個實例中打開的工作簿的名稱，則可以獲取對應用程序對象的引用。 參見艾倫·韋特（Allen Waytt）的頁面

最后一部分

Dim xlApp As Excel.Application
Set xlApp = GetObject("c:\\mypath\\ExampleBook.xlsx").Application

允許我獲得打開ExampleBook.xlsx的實例的應用程序對象的指針。

我認為“ ExampleBook”必須是完整的路徑，至少在Excel 2010中是如此。我目前正在自己​​進行嘗試，因此，我將在嘗試獲得更多詳細信息時嘗試進行更新。

如果單獨的實例打開了相同的工作簿，則可能會有復雜的情況，但是只有一個實例具有寫訪問權限。

Answer 4

多虧了這篇出色的文章，我有了一個例程才能找到返回計算機上當前正在運行的所有Excel應用程序的數組。 問題是我剛剛升級到64位Office 2013，但一切都出錯了。

通常將... Declare Function ...轉換為... Declare PtrSafe Function ... ，這在其他地方都有詳細記錄。 但是，我找不到任何文檔的事實是，此升級后原始代碼期望的窗口層次結構（“ XLMAIN”->“ XLDESK”->“ EXCEL7”）已更改。 對於那些追隨我的腳步的人，為了節省您一個下午的閑逛時間，我想我應該發布更新后的腳本。 很難測試，但我認為它也應該向后兼容，以取得良好的效果。

Option Explicit

#If Win64 Then

    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
    Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef lpiid As UUID) As LongPtr
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal Hwnd As LongPtr, ByVal dwId As LongPtr, ByRef riid As UUID, ByRef ppvObject As Object) As LongPtr

#Else

    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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

#End If

Type UUID 'GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As LongPtr = &HFFFFFFF0

' Run as entry point of example
Public Sub Test()

Dim i As Long
Dim xlApps() As Application

    If GetAllExcelInstances(xlApps) Then
        For i = LBound(xlApps) To UBound(xlApps)
            If xlApps(i).Workbooks(1).Name <> ThisWorkbook.Name Then
                MsgBox (xlApps(i).Workbooks(1).Name)
            End If
        Next
    End If

End Sub

' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long

On Error GoTo MyErrorHandler

Dim n As Long
#If Win64 Then
    Dim hWndMain As LongPtr
#Else
    Dim hWndMain As Long
#End If
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
        Set app = GetExcelObjectFromHwnd(hWndMain)
        If Not (app Is Nothing) Then
            If n = 0 Then
                n = n + 1
                Set xlApps(n) = app
            ElseIf checkHwnds(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

    Exit Function

MyErrorHandler:
    MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

#If Win64 Then
    Private Function checkHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
#Else
    Private Function checkHwnds(xlApps() As Application, Hwnd As Long) As Boolean
#End If

Dim i As Integer

    For i = LBound(xlApps) To UBound(xlApps)
        If xlApps(i).Hwnd = Hwnd Then
            checkHwnds = False
            Exit Function
        End If
    Next i

    checkHwnds = True

End Function

#If Win64 Then
    Private Function GetExcelObjectFromHwnd(ByVal hWndMain As LongPtr) As Application
#Else
    Private Function GetExcelObjectFromHwnd(ByVal hWndMain As Long) As Application
#End If

On Error GoTo MyErrorHandler

#If Win64 Then
    Dim hWndDesk As LongPtr
    Dim Hwnd As LongPtr
#Else
    Dim hWndDesk As Long
    Dim Hwnd As Long
#End If
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 GetExcelObjectFromHwnd = obj.Application
                Exit Function

            End If

        End If

        Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
        Loop

        On Error Resume Next

    End If

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

Answer 5

我有類似的問題/目標。

而且我得到了ForEachLoops答案，但是需要進行一些更改。 在底部函數（GetExcelObjectFromHwnd）中，他在兩個debug.print命令中都使用了工作簿索引1。 結果是您只看到第一個白平衡。

因此，我接受了他的代碼，並將for循環放入GetExcelObjectFromHwnd內，並將1更改為一個計數器。 結果是我可以獲得所有活動的excel工作簿，並返回跨Excel實例訪問其他WB所需的信息。

我創建了一個Type來簡化信息的檢索並將其傳遞回調用子例程：

Type TargetWBType
    name As String
    returnObj As Object
    returnApp As Excel.Application
    returnWBIndex As Integer
End Type

對於名稱，我只使用了基本文件名，例如“ example.xls”。 該代碼段通過在目標WB的每個WS上分配A6的值來證明其功能。 像這樣：

Dim targetWB As TargetWBType
targetWB.name = "example.xls"

Call GetAllWorkbookWindowNames(targetWB)

If Not targetWB.returnObj Is Nothing Then
    Set targetWB.returnApp = targetWB.returnObj.Application
    Dim ws As Worksheet
    For Each ws In targetWB.returnApp.Workbooks(targetWB.returnWBIndex).Worksheets
        MsgBox ws.Range("A6").Value
    Next
Else
    MsgBox "Target WB Not found"
End If

因此，現在ForEachLoop最初創建的ENTIRE模塊看起來像這樣，並且我已經指出了所做的更改。 它確實有一個msgbox彈出窗口，我留在代碼段中用於調試。 找到目標后將其剝離。 代碼：

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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

Type UUID 'GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

'------------- Form Module --------------

Option Explicit

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

'My code: added targetWB
Sub GetAllWorkbookWindowNames(targetWB As TargetWBType)
    On Error GoTo MyErrorHandler

    Dim hWndMain As Long
    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        GetWbkWindows hWndMain, targetWB 'My code: added targetWB
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    Exit Sub

MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

'My code: added targetWB
Private Sub GetWbkWindows(ByVal hWndMain As Long, targetWB As TargetWBType)
    On Error GoTo MyErrorHandler

    Dim hWndDesk As Long
    hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

    If hWndDesk <> 0 Then
        Dim hWnd As Long
        hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

        Dim strText As String
        Dim lngRet As Long
        Do While hWnd <> 0
            strText = String$(100, Chr$(0))
            lngRet = GetClassName(hWnd, strText, 100)

            If Left$(strText, lngRet) = "EXCEL7" Then
                GetExcelObjectFromHwnd hWnd, targetWB 'My code: added targetWB
                Exit Sub
            End If

            hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
            Loop

        On Error Resume Next
    End If

    Exit Sub

MyErrorHandler:
    MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

'My code: added targetWB
Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long, targetWB As TargetWBType) As Boolean
    On Error GoTo MyErrorHandler

    Dim fOk As Boolean
    fOk = False

    Dim iid As UUID
    Call IIDFromString(StrPtr(IID_IDispatch), iid)

    Dim obj As Object
    If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
        Dim objApp As Excel.Application
        Set objApp = obj.Application

        'My code
        Dim wbCount As Integer
        For wbCount = 1 To objApp.Workbooks.Count
        'End my code

            'Not my code
            Debug.Print objApp.Workbooks(wbCount).name

            'My code
                If LCase(objApp.Workbooks(wbCount).name) = LCase(targetWB.name) Then
                    MsgBox ("Found target: " & targetWB.name)
                    Set targetWB.returnObj = obj
                    targetWB.returnWBIndex = wbCount
                End If
            'End My code

            'Not my code
            Dim myWorksheet As Worksheet
            For Each myWorksheet In objApp.Workbooks(wbCount).Worksheets
                Debug.Print "     " & myWorksheet.name
                DoEvents
            Next

        'My code
        Next
        'Not my code

        fOk = True
    End If

    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

我重復一遍，這可行，並且使用TargetWB類型中的變量，我可以跨Excel實例可靠地訪問工作簿和工作表。

我在解決方案中看到的唯一潛在問題是，如果您有多個具有相同名稱的WB。 現在，我相信它將返回該名稱的最后一個實例。 如果我們在If If中添加Exit For，我相信它將代替它的第一個實例。 我沒有認真地測試這部分，因為在我的應用程序中，只有一個打開的文件實例。

Answer 6

只是為了補充James MacAdie的答案，我認為您做redim的時間太晚了，因為在checkHwnds函數中，即使您尚未填充最大100的值，也會遇到超出范圍的錯誤，因為您嘗試檢查的值最多為100完全排列？ 我將代碼修改為下面的代碼，現在可以為我工作了。

' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long

On Error GoTo MyErrorHandler

Dim n As Long
#If Win64 Then
    Dim hWndMain As LongPtr
#Else
    Dim hWndMain As Long
#End If
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
    Set app = GetExcelObjectFromHwnd(hWndMain)
    If Not (app Is Nothing) Then
        If n = 0 Then
            n = n + 1
            ReDim Preserve xlApps(1 To n)
            Set xlApps(n) = app
        ElseIf checkHwnds(xlApps, app.Hwnd) Then
            n = n + 1
            ReDim Preserve xlApps(1 To n)
            Set xlApps(n) = app
        End If
    End If
    hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop

If n Then
    GetAllExcelInstances = n
Else
    Erase xlApps
End If

Exit Function

MyErrorHandler:
    MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description

End Function

Answer 7

我認為僅使用VBA是不可能的，因為您可以訪問的最高級別的對象是Application對象，它是Excel的當前實例。