VBA 可以跨越 Excel 实例吗？

Can VBA Reach Across Instances of Excel?

提问by I. J. Kennedy

Can an Excel VBA macro, running in one instance of Excel, access the workbooks of another running instance of Excel? For example, I would like to create a list of all workbooks that are open in any running instance of Excel.

在一个 Excel 实例中运行的 Excel VBA 宏能否访问另一个正在运行的 Excel 实例的工作簿？例如，我想创建在任何运行的 Excel 实例中打开的所有工作簿的列表。

回答by ForEachLoop

Cornelius' answer is partially correct. His code gets the current instance and then makes a new instance. GetObjectonly ever gets the first instance, no matter how many instances are available. The question I believe is how can you get a specific instance from among many instances.

科尼利厄斯的回答部分正确。他的代码获取当前实例，然后创建一个新实例。无论有多少实例可用，GetObject只会获取第一个实例。我认为的问题是如何从众多实例中获取特定实例。

For a VBA project, make two modules, one code module, and the other as a form with one command button named Command1. You might need to add a reference to Microsoft.Excel.

对于 VBA 项目，制作两个模块，一个是代码模块，另一个是带有一个名为 Command1 的命令按钮的表单。您可能需要添加对 Microsoft.Excel 的引用。

This code displays all the name of each workbook for each running instance of Excel in the Immediate window.

此代码在“立即”窗口中显示每个正在运行的 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

回答by Marek

I believe that VBA is more powerful than Charles thinks ;)

我相信 VBA 比 Charles 认为的更强大；)

If there is only some tricky way to point to the specific instance from GetObject and CreateObjectwe'll have your problem solved!

如果只有一些棘手的方法可以从GetObject 和 CreateObject指向特定实例，我们将解决您的问题！

EDIT:

编辑：

If you're the creator of all the instances there should be no problems with things like listing workbooks. Take a look on this code:

如果您是所有实例的创建者，那么列出工作簿之类的事情应该没有问题。看看这段代码：

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

回答by Flakker

I think that within VBA you can get access to the application object in another running instance. If you know the name of a workbook open within the other instance, then you can get a reference to the application object. See Allen Waytt's page

我认为在 VBA 中，您可以访问另一个正在运行的实例中的应用程序对象。如果您知道在另一个实例中打开的工作簿的名称，则可以获得对应用程序对象的引用。见艾伦威特的页面

The last part,

最后一部分，

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

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

Allowed me to get a pointer to the application object of the instance that had ExampleBook.xlsxopen.

允许我获取指向已ExampleBook.xlsx打开实例的应用程序对象的指针。

I believe "ExampleBook" needs to be the full path, at least in Excel 2010. I'm currently experimenting with this myself, so I will try and update as I get more details.

我相信“ExampleBook”需要是完整路径，至少在 Excel 2010 中是这样。我目前自己正在试验这个，所以我会在获得更多详细信息时尝试更新。

Presumably there may be complications if separate instances have the same workbook open, but only one may have write access.

如果单独的实例打开相同的工作簿，但可能只有一个具有写访问权限，那么可能会出现复杂情况。

回答by James MacAdie

Thanks to this great post I had a routine to find return an array of all Excel applications currently running on the machine. Trouble is that I've just upgraded to Office 2013 64 bit and it all went wrong.

感谢这篇很棒的帖子，我有一个例程来查找当前在机器上运行的所有 Excel 应用程序的数组。问题是我刚刚升级到 Office 2013 64 位，但一切都出错了。

There is the usual faff of converting ... Declare Function ...into ... Declare PtrSafe Function ..., which is well documented elsewhere. However, what I couldn't find any documentation on is that fact that the window hierarchy ('XLMAIN' -> 'XLDESK' -> 'EXCEL7') that the original code expects has changed following this upgrade. For anyone following in my footsteps, to save you an afternoon of digging around, I thought I'd post my updated script. It's hard to test, but I think it should be backwards compatible too for good measure.

通常有转换... 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

回答by user2854823

I had a similar problem/goal.

我有一个类似的问题/目标。

And I got ForEachLoops answer working, but there is a change that needs made. In the bottom function (GetExcelObjectFromHwnd), he used the workbook index of 1 in both debug.print commands. The result is you only see the first WB.

我得到了 ForEachLoops 答案，但需要做出改变。在底部函数 (GetExcelObjectFromHwnd) 中，他在两个 debug.print 命令中都使用了工作簿索引 1。结果是您只能看到第一个 WB。

So I took his code, and put a for loop inside GetExcelObjectFromHwnd, and changed the 1 to a counter. the result is I can get ALL active excel workbooks and return the information I need to reach across instances of Excel and access other WB's.

所以我拿了他的代码，在 GetExcelObjectFromHwnd 里面放了一个 for 循环，把 1 改成了一个计数器。结果是我可以获得所有活动的 excel 工作簿并返回我需要跨 Excel 实例访问并访问其他 WB 的信息。

And I created a Type to simplify retrieving of the info and pass it back to the calling subroutine:

我创建了一个 Type 来简化信息的检索并将其传递回调用子例程：

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

For name I simply used the base filename, e.g. "example.xls". This snippet proves the functionality by spitting out the value of A6 on every WS of the target WB. Like so:

对于名称，我只是使用了基本文件名，例如“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

So now the ENTIRE module that ForEachLoop originally made looks like this, and I've indicated the changes I made. It does have a msgbox popup, whcih I left in the snippet for debugging purposes. Strip that out once it's finding your target. The code:

所以现在 ForEachLoop 最初制作的整个模块看起来像这样，我已经指出了我所做的更改。它确实有一个 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

I repeat, this works, and using the variables within the TargetWB type I am reliably accessing workbooks and worksheets across instances of Excel.

我再说一遍，这行得通，并且使用 TargetWB 类型中的变量，我可以跨 Excel 实例可靠地访问工作簿和工作表。

The only potential problem I see with my solution, is if you have multiple WB's with the same name. Right now, I believe it would return the last instance of that name. If we add an Exit For into the If Then I believe it will instead return the first instance of it. I didn't test this part thouroughly as in my application there is only ever one instance of the file open.

我在我的解决方案中看到的唯一潜在问题是，如果您有多个同名的 WB。现在，我相信它会返回该名称的最后一个实例。如果我们将 Exit For 添加到 If Then 我相信它会返回它的第一个实例。我没有彻底测试这部分，因为在我的应用程序中，只有一个打开的文件实例。

回答by Steve_m

Just to add to James MacAdie's answer, I think you do the redim too late because in the checkHwnds function you end up with an out of range error as you're trying to check values up to 100 even though you haven't yet populated the array fully? I modified the code to the below and it's now working for me.

只是为了补充 James MacAdie 的回答，我认为你做 redim 为时已晚，因为在 checkHwnds 函数中你最终会出现超出范围的错误，因为你试图检查高达 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

回答by Charles Williams

I don't believe this is possible using only VBA because the highest level object you can get to is the Application object which is the current instance of Excel.

我认为仅使用 VBA 是不可能的，因为您可以访问的最高级别对象是 Application 对象，它是 Excel 的当前实例。