VBA可以跨越Excel的实例吗？
在Excel的一个实例中运行的Excel VBAmacros是否可以访问另一个正在运行的Excel实例的工作簿？ 例如，我想创build一个在任何正在运行的Excel实例中打开的所有工作簿的列表。
科尼利厄斯的回答是部分正确的。 他的代码获取当前实例，然后创build一个新实例。 无论有多less实例可用， GetObject只能获得第一个实例。 我相信的问题是如何从多个实例中获得特定的实例。
对于VBA项目，使用一个名为Command1的命令button创build两个模块，一个代码模块，另一个作为窗体。 您可能需要添加对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
我相信VBA比Charles想象的更强大）
如果只有一些棘手的方法指向GetObject和CreateObject的特定实例，我们将解决您的问题！
编辑：
如果您是所有实例的创build者，那么列出工作簿等内容应该没有问题。 看看这个代码：
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
我认为，在VBA中，您可以访问另一个正在运行的实例中的应用程序对象 。 如果您知道在其他实例中打开的工作簿的名称，则可以获取对应用程序对象的引用。 见艾伦韦特的页面
最后一部分，
Dim xlApp As Excel.Application
Set xlApp = GetObject("c:\mypath\ExampleBook.xlsx").Application
允许我获取指向已打开ExampleBook.xlsx的实例的应用程序对象的指针。
至less在Excel 2010中，我相信“ExampleBook”需要成为完整的path。我目前正在尝试这个，所以我会尝试更新，因为我会得到更多的细节。
据推测，如果单独的实例打开相同的工作簿，但只有一个可能具有写访问权限，则可能会有复杂性。
感谢这个伟大的职位，我有一个例程来查找返回当前在机器上运行的所有Excel应用程序的数组。 麻烦的是，我刚刚升级到Office 2013 64位，这一切都出错了。
有通常的转换... Declare Function ...到... Declare PtrSafe Function ... ，这是其他地方很好地logging。 然而，我找不到任何文档是这样的事实，即原始代码期望的窗口层次结构（'XLMAIN' – >'XLDESK' – >'EXCEL7'）在此升级之后已经改变。 对于任何追随我脚步的人，为了节省下午的时间，我想我会发布我更新的脚本。 这是很难testing，但我认为这应该是向后兼容的好办法。
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
我有一个类似的问题/目标。
我得到了ForEachLoops解答工作，但有需要的变化。 在底层函数（GetExcelObjectFromHwnd）中，他在两个debug.print命令中都使用1的工作簿索引。 结果是你只能看到第一个WB。
所以我拿了他的代码，并在GetExcelObjectFromHwnd中放置一个for循环，并将1更改为一个计数器。 结果是我可以得到所有活动的Excel工作簿，并返回我需要跨Excel实例访问的信息，并访问其他WB。
我创build了一个types来简化信息的检索并将其传递callback用子例程：
Type TargetWBType name As String returnObj As Object returnApp As Excel.Application returnWBIndex As Integer End Type
对于名字我简单地使用了基本文件名，例如“example.xls”。 该代码片段通过在目标WB的每个WS上吐出A6的值来certificate该function。 像这样：
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最初制作的整个模块看起来就像这样，而且我已经指出了我所做的更改。 它有一个msgboxpopup窗口，为了进行debugging，我将其保留在代码片段中。 一旦它find你的目标，将其剥离。 代码：
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
我再说一遍，这是有效的，并且使用TargetWBtypes中的variables，我可以可靠地访问Excel实例中的工作簿和工作表。
我用我的解决scheme看到的唯一的潜在问题是，如果你有多个同名的WB。 现在，我相信它会返回这个名字的最后一个例子。 如果我们添加一个Exit For成为If然后我相信它会返回它的第一个实例。 我没有全面testing这个部分，因为在我的应用程序中只有一个打开的文件实例。
只要添加到James MacAdie的答案，我认为你做的redim太迟了，因为在checkHwnds函数，你最终会超出范围的错误，因为你试图检查值高达100，即使你还没有填充arrays完全？ 我修改了下面的代码，它现在正在为我工作。
' 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
我不相信这是可能的只使用VBA，因为您可以访问的最高级别的对象是Excel的当前实例的应用程序对象。
