Userform und weitere Exceldateien

' UserForm-Icon in Taskleiste und Minimieren im Rahmen
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" _
Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongA Lib "user32.dll" _
Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Private Const ciFakt = 2
#Else
Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Private Const ciFakt = 1
#End If
Private Const ciInitTab As Long = 12 * ciFakt
Private Const ciAddTab  As Long = 16 * ciFakt
Private Const ciActTab  As Long = 24 * ciFakt
Private Const ciDelTab  As Long = 20 * ciFakt
Private Const ciToolTip As Long = 76 * ciFakt
Private Const ciSetVal  As Long = 24 * ciFakt
Private Const ciCommit  As Long = 28 * ciFakt
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As Any) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32.dll" ( _
ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" ( _
ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, _
ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, _
ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Function CoCreateInstance Lib "ole32" ( _
ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, _
ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" ( _
ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
Private Declare PtrSafe Function SHGetPropertyStoreForWindow Lib "Shell32.dll" ( _
ByVal hwnd As LongPtr, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Dim tClsID As GUID, tIID As GUID
Private Type PROPERTYKEY
fmtid As GUID
pid   As Long
End Type
Dim tPK As PROPERTYKEY
Dim mhWndUF   As LongPtr, mhVBE As LongPtr                  ' Handle Userform und VBE-Editor
Dim lpBarList As LongPtr, lpStore As LongPtr
Dim mbVBE     As Boolean
'Benötigt um das Userform minimieren zu können.
Const GWL_HWNDPARENT = (-8)
Const GWL_STYLE = -16&
Const WS_CAPTION = &HC00000                               ' >>>>
Const WS_MINIMAXIMIZEBOX = &H20000 '&H30000               ' WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
Const HWND_TOPMOST = -1                                   ' Userform allways on top
Const WM_SETICON = &H80
Dim hIcon As LongPtr
' >>>>
hIcon = Image1.Picture.Handle                             ' Handle für Icon aus UF nehmen
' hIcon = Tabelle1.Image1.Picture.Handle                    ' Handle für Icon aus Sheet nehmen
mhVBE = FindWindowA("wndclass_desked_gsk", vbNullString)  ' Handle des VBE-Editor holen
mhWndUF = FindWindowA("ThunderDFrame", Caption)           ' Handle der Userform holen
SetWindowLongA mhWndUF, GWL_STYLE, GetWindowLongA(mhWndUF, GWL_STYLE) _
Or WS_MINIMAXIMIZEBOX             ' Mini/Maxiboxen zufügen
'  SetWindowLongA mhWndUF, GWL_STYLE, GetWindowLongA(mhWndUF, GWL_STYLE) _
And Not WS_CAPTION '              ' >>>>
' DrawMenuBar mhWndUF                                       ' >>>>
SendMessageA mhWndUF, WM_SETICON, 0&, hIcon               ' Icon in Caption setzen
SetWindowLongA mhWndUF, GWL_HWNDPARENT, 0                 ' Das Elternfenster der Userform entfernen
'SetWindowPos mhWndUF, HWND_TOPMOST, 0, 0, 0, 0, &H3       ' UF immer im Vordergrund >>>>
Application.Visible = False                               ' Excel anzeigen aus
Private Sub UserForm_Activate()
Const GWL_EXSTYLE = -20
Const WS_EX_APPWINDOW = &H40000
Dim i As Integer
ShowWindow mhWndUF, 1        ' 1 = SW_HIDE                ' UF anzeigen ein
SetWindowLongA mhWndUF, GWL_EXSTYLE, GetWindowLongA(mhWndUF, GWL_EXSTYLE) _
Or WS_EX_APPWINDOW                ' Fensterstyle ändern
SetTaskBar "Dialogbox " & Caption & " wieder aktivieren"  ' >>>>
End Sub
'Benötigte Prozeduren um das Userform zu minimieren, sowie das Icon des USerfirms in der Taskleiste darzustellen
Private Sub SetTaskBar(Optional sToolTip As String)
' Teile von Jaafar Tribak verwendet
Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
Const IID_PropertyKey = "{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}"
Const CLSID_TASKLIST = "{56FDF344-FD6D-11D0-958A-006097C9A090}"
Const IID_TASKLIST = "{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}"
Const CLSCTX_INPROC_SERVER = &H1
Const S_OK = 0
Call CLSIDFromString(StrPtr(IID_PropertyStore), tIID)
If SHGetPropertyStoreForWindow(mhWndUF, tIID, lpStore) = S_OK Then
Call CLSIDFromString(StrPtr(IID_PropertyKey), tPK)
#If Win64 Then
Dim PV(2) As LongPtr
PV(1) = StrPtr("Dummy")
#Else
Dim PV(3) As LongPtr
PV(2) = StrPtr("Dummy")
#End If
tPK.pid = 5: PV(0) = 31
SetTabList 0, ciSetVal, VarPtr(tPK), VarPtr(PV(0))    ' SetValue Methode
SetTabList 0, ciCommit                                ' Commit Methode ggf. überflüssig
Call CLSIDFromString(StrPtr(CLSID_TASKLIST), tClsID)
Call CLSIDFromString(StrPtr(IID_TASKLIST), tIID)
If CoCreateInstance(tClsID, 0, CLSCTX_INPROC_SERVER, tIID, lpBarList) = S_OK Then
SetTabList 1, ciInitTab                            ' Tab initialisieren
SetTabList 1, ciAddTab, mhWndUF                    ' Tab Userform zufügen
SetTabList 1, ciActTab, mhWndUF                    ' Tab Userform aktivieren
If Len(sToolTip) Then _
SetTabList 1, ciToolTip, mhWndUF, StrPtr(sToolTip) ' ToolTip hinzufügen
' VBE-Editor ausblenden
If IsWindowVisible(mhVBE) Then                     ' Nur wenn sichtbar
ShowWindow mhVBE, 0 ' 0 = SW_HIDE               ' VBE-Editor ausblenden
SetTabList 1, ciDelTab, mhVBE                   ' Tab VBE-Editor löschen
mbVBE = True
End If
SetTabList 1, ciDelTab, Application.hwnd           ' Tab Excel-Application löschen
End If
End If
Application.Visible = False
End Sub
Private Sub ResetTaskbar()
' Bereinigen der Taskleiste
SetTabList 1, ciDelTab, mhWndUF                           ' Tab Userform löschen
If mbVBE Then                                             ' (optional)
SetTabList 1, ciAddTab, mhVBE                          ' Tab VBE-Editor zufügen
ShowWindow mhVBE, 5  ' 5 = SW_SHOW                     ' VBE-Editor wieder anzeigen
End If
SetTabList 1, ciAddTab, Application.hwnd                  ' Tab Excel-Application zufügen
End Sub
Private Sub SetTabList(iPtArt As Integer, iTblOffs As Long, ParamArray vFuncParams() As Variant)
' Setzen der Taskleiste mit den gewünschten Elementen
' Teile von Jaafar Tribak verwendet
Const CC_STDCALL = 4
Dim vParamPtr()  As LongPtr, hInst As LongPtr
Dim vParamType() As Integer
Dim vRtn         As Variant
Dim vParams()    As Variant
Dim iMax As Long, i As Long
vParams() = vFuncParams()
iMax = Abs(UBound(vParams) - LBound(vParams) + 1&)
If iMax = 0& Then
ReDim vParamPtr(0 To 0)
ReDim vParamType(0 To 0)
Else
ReDim vParamPtr(0 To iMax - 1&)
ReDim vParamType(0 To iMax - 1&)
For i = 0& To iMax - 1&
vParamPtr(i) = VarPtr(vParams(i))
vParamType(i) = VarType(vParams(i))
Next i
End If
hInst = IIf(iPtArt = 1, lpBarList, lpStore)
DispCallFunc hInst, iTblOffs, CC_STDCALL, vbLong, iMax, vParamType(0), vParamPtr(0), vRtn
End Sub