Datei in mehreren Instanzen suchen

[volti]

Hallo liebe Leserin, lieber Leser,

manchmal hat man aus irgendwelchen Gründen Dateien geöffnet, die sich in mehreren Excel-Instanzen befinden.
Will man diese schließen oder eine bestimmte Datei via Workbook-Schleife finden, scheitert man oft, da nur in der eigenen Instanz gesucht wird.

Nachfolgende Funktion ermittelt alle vorhandenen Excel-Instanzen, die man nun für seine Zwecke nutzen kann.

Viel Erfolg beim Testen.

Code:

Private Declare PtrSafe Function GetClassNameA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpClassName As String, _
        ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
        ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" ( _
        ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, _
        ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Sub IIDFromString Lib "ole32.dll" ( _
        ByVal lpsz As String, ByRef lpiid As GUID)
Private Declare PtrSafe Sub AccessibleObjectFromWindow Lib "oleacc.dll" ( _
        ByVal hwnd As LongPtr, ByVal dwId As Long, _
        ByRef riid As GUID, ByRef ppvObject As Any)

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type
Private mtGuid As GUID
Private Const IID_EXCELWINDOW As String = "{00020893-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM  As Long = &HFFFFFFF0
Private moTmpApplications()   As Application
Private miAnz     As Long
Private msAllHWnd As String, msClassname As String * 16

Function GetApplications() As Application()
' Alle Kinder-Fenster über die geladenen Eltern-Fenster ermitteln
  miAnz = 1
  Erase moTmpApplications: msAllHWnd = ","          ' Array zurücksetzen
  
' Konvertiere die IID des Excel-Window-Objektes in die GUID-Struktur
  Call IIDFromString(StrConv(IID_EXCELWINDOW, vbUnicode), mtGuid)

  Call EnumWindows(AddressOf EnumAppsProc, ByVal 0&)
  GetApplications = moTmpApplications               ' Array zurückgeben

End Function

Private Function EnumAppsProc(ByVal hwnd As LongPtr, ByVal lParam As Long) As Long
' Durchlaufe alle Eltern-Fenster
  If Left$(msClassname, GetClassNameA(hwnd, msClassname, 16)) = "XLMAIN" Then
     EnumChildWindows hwnd, AddressOf EnumXlsProc, ByVal 0&
  End If
  EnumAppsProc = 1                                  ' Nächster Aufruf
End Function

Private Function EnumXlsProc(ByVal hwnd As LongPtr, ByVal lParam As Long) As Long
' Durchlaufe alle Kinder-Fenster bis EXCEL7 gefunden
  Dim oWin As Window, hWndApp As LongPtr

  If Left$(msClassname, GetClassNameA(hwnd, msClassname, 16)) = "EXCEL7" Then

' Hole über die Zugriffsnummer das entsprechende Window-Objekt
     Call AccessibleObjectFromWindow(hwnd, OBJID_NATIVEOM, mtGuid, oWin)

' Verweis setzen auf Application-Objekt
     If Not oWin Is Nothing Then
        hWndApp = oWin.Application.hwnd
        If InStr(msAllHWnd, "," & hWndApp & ",") = 0 Then
           ReDim Preserve moTmpApplications(miAnz)
           Set moTmpApplications(miAnz) = oWin.Application
           msAllHWnd = msAllHWnd & hWndApp & ","
           miAnz = miAnz + 1
        End If
     End If
     Exit Function                              ' Fertig mit Job
  End If
  EnumXlsProc = 1                               ' Nächster Aufruf
End Function

' ##### Aufrufbeispiele #####
Sub SchließeAlleAnderenInstanzen()
' Sub beendet alle anderen Excel-Instanzen außer der Aktuellen
  Dim oApps() As Application, WkB As Workbook
  Dim i As Long, bIsThis As Boolean
  
  oApps = GetApplications                       ' Hole die Excel-Instanzen

  For i = 1 To UBound(oApps)
      bIsThis = False
      For Each WkB In oApps(i).Workbooks
          bIsThis = WkB Is ThisWorkbook         ' Beinhaltet Instanz diese Datei?
          If bIsThis Then Exit For              ' Wenn ja => raus
      Next WkB
      oApps(i).DisplayAlerts = False
      If bIsThis = False Then
         oApps(i).DisplayAlerts = False
         oApps(i).Quit                          ' Diese Excel-Instanz beenden
      End If
  Next i
End Sub

Sub SucheDateiInAllesInstanzen()
' Sub sucht eine offene Mappe in allen Excel-Instanzen
  Dim oApps() As Application, WkB As Workbook
  Dim i As Long, sMappe As String
  
  sMappe = ThisWorkbook.Name
  oApps = GetApplications                       ' Hole die Excel-Instanzen

  For i = 1 To UBound(oApps)
      For Each WkB In oApps(i).Workbooks
          If WkB.Name Like sMappe Then
             MsgBox "Workbook '" & sMappe & "' gefunden in Instanz " _
                  & i & " von " & UBound(oApps) & " Instanz(en)!", _
                    vbInformation
          End If
      Next WkB
  Next i
End Sub

_________
viele Grüße
Karl-Heinz