AW: Datei in zweiter Instanz
01.09.2020 08:32:43
volti
Hier noch eine kleine Anpassung..
[+][-]
Option Explicit
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
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 Const IID_EXCELWINDOW = "{00020893-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private hWndChild() As LongPtr, iChildCount As Long
Private hWwndMain() As LongPtr, iWindowCount As Long
Private sAllHandles As String
Private Function GetApplications() As Application()
Dim i As Long, iCount As Long
Dim udtGuid As GUID, oWin As Window
Dim oTmpApplications() As Application
'Variablen zurücksetzen
Erase hWndChild: iChildCount = 0
Erase hWwndMain: iWindowCount = 0
'Konvertiere die IID des Excel-Window-Objektes in die GUID-Struktur
Call IIDFromString(StrConv(IID_EXCELWINDOW, vbUnicode), udtGuid)
'Alle geladenen Eltern-Fenster ermitteln
Call EnumWindows(AddressOf EnumWindowProc, ByVal 0&)
'Alle gefundenen Eltern-Excelfenster durchgehen
For i = LBound(hWwndMain) To UBound(hWwndMain)
'Alle Kinder-Fenster der gefundenen Elternfenster ermitteln
Call EnumChildWindows(hWwndMain(i), _
AddressOf EnumChildWindowProc, ByVal 0&)
Next i
'Alle Kinder-Fenster durchgehen
sAllHandles = ","
For i = LBound(hWndChild) To UBound(hWndChild)
'Hole über die Zugriffsnummer das entsprechende Window-Objekt
Call AccessibleObjectFromWindow(hWndChild(i), _
OBJID_NATIVEOM, udtGuid, oWin)
'Verweis setzen auf Application-Objekt
If Not oWin Is Nothing Then
If InStr(sAllHandles, "," & CStr(oWin.Application.hWnd) & ",") = 0 Then
ReDim Preserve oTmpApplications(iCount)
Set oTmpApplications(iCount) = oWin.Application
iCount = iCount + 1
sAllHandles = sAllHandles & CStr(oWin.Application.hWnd) & ","
End If
End If
Next i
'Array über die Functon zurückgeben
GetApplications = oTmpApplications
End Function
Function SucheOffeneExcelmappe()
'Diese Sub ggf. in Private Sub Workbook_Open() einbinden
Dim oApplications() As Application, WkB As Workbook
Dim i As Long
Dim sSuch As String
sSuch = "Smart-Board.xlsm"
oApplications = GetApplications
For i = LBound(oApplications) To UBound(oApplications)
For Each WkB In oApplications(i).Workbooks
If WkB.Name Like sSuch Then
'Mach was.....
MsgBox "Workbook " & WkB.Name & " wurde gefunden!", vbInformation, "Excel-Instanzen"
' WkB.Close SaveChanges:=True 'Workbook schließen
' oApplications(i).Quit 'Diese Excel-Instanz beenden
Exit Function
End If
Next WkB
Next i
MsgBox "Mappe '" & sSuch & "' ist nicht geöffnet!", vbInformation
End Function
_______________
viele Grüße aus Freigericht
Karl-Heinz