VBA可以跨越Excel的實例嗎？

29

科尼利厄斯的答案是部分正確的。他的代碼獲取當前實例，然後創建一個新實例。 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

來源

2010-07-21 19:27:14 ForEachLoop

+0

僅供參考，Microsoft Access的類名是'OMain'。我修改了這段代碼，可以輕鬆識別開放的Microsoft Access數據庫。 – AdamsTips 2017-10-27 22:12:37

-4

我不相信這是可能的只使用VBA，因爲您可以訪問的最高級別的對象是應用程序對象，它是當前的Excel實例。

來源

2010-06-04 11:46:43

8

我相信VBA比查爾斯認爲更強大;）

如果只有從GetObject and 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

來源

2010-06-04 12:19:49 Marek

5

我認爲，在VBA內，你可以訪問應用程序對象在另一個運行實例。如果您知道在其他實例中打開的工作簿的名稱，則可以獲取對該應用程序對象的引用。見Allen Waytt's page

最後一部分，

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

讓我得到一個指針，有ExampleBook.xlsx開放實例的應用對象。

我相信「ExampleBook」必須是完整的路徑，至少在Excel 2010中。我目前正在嘗試這個，所以我會嘗試更新，因爲我會得到更多的細節。

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

來源

2013-03-23 14:32:29 Flakker

+0

當我使用完整路徑時，+1爲我工作了一個vbs，http://stackoverflow.com/questions/20849853/running-vbscript-function-from-vba/20850129#20850129 – brettdj 2014-01-01 09:25:05

4

我有一個類似的問題/目標。

而且我得到了ForEachLoops答案，但是需要做出改變。在底層函數（GetExcelObjectFromHwnd）中，他在兩個debug.print命令中都使用1的工作簿索引。結果是你只能看到第一個WB。

所以我拿了他的代碼，並在GetExcelObjectFromHwnd中放置一個for循環，並將1更改爲一個計數器。結果是我可以獲得所有活動的Excel工作簿，並返回我需要跨Excel實例訪問的信息並訪問其他WB。

我創建了一個類型，以簡化信息的檢索，並將其傳遞迴調用子程序：

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

所以現在整個模塊foreach循環原先作出這個樣子的，我已經表明我所做的更改。它有一個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。現在，我相信它會返回該名稱的最後一個實例。如果我們將Exit For添加到If中，那麼我相信它會返回它的第一個實例。我沒有完全測試這個部分，因爲在我的應用程序中只有一個文件實例處於打開狀態。

來源

2013-10-07 13:15:53 user2854823

5

感謝這篇不錯的文章，我有一個例程來查找返回當前在機器上運行的所有Excel應用程序的數組。麻煩的是，我剛剛升級到Office 2013 64位，它都出錯了。

有一種將... 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

來源

2015-02-13 17:03:18

+0

你應該根據你的具體情況創建另一個問題情況，然後回答。搜索的人不一定會在這裏找到你的答案。 – guitarthrower 2015-02-13 17:15:21

+3

我明白你的觀點，但我覺得我正在解決原來的問題。自從問題被問到/回答以來，Excel已經開始發展，任何想要用今天的軟件解決問題的人都需要做一些不同的事情。我提供了這個更新，這只是對原始答案的一個小調整。 – 2015-02-13 23:00:32

+0

因爲我也有excele 2°13 64bit，我只會在這裏發表評論：在checkHwnds中發現錯誤：th循環必須停止在n而不是100，因此您需要將n作爲參數傳遞給checkHwnds。 – 2017-10-28 15:32:42

0

我想補充詹姆斯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

來源

2017-05-17 22:55:29

VBA可以跨越Excel的實例嗎？

回答

相關問題