Untitled

Fensterliste, Menüs anderer Programme

Vor Jahren hatte ich mal vor dem Problem gestanden, ein anderes Programm zu veranlassen, seine Arbeit alle Stunde zu sichern. Leider war da nix mit OLE und Co.
Also habe ich mit SendKeys gearbeitet. Was soll ich sagen, eine mittlere Katastrophe. Nicht nur, dass es immer nur ein paar Stunden geklappt hat, nein, auch ging das SendKeys danach überall hin und richtete zusätzlichen Schaden an.
Das Programm enthielt aber ein Menü. Und seit "Hardcore Visual Basic" wusste ich, dass man Menüs anderer Programme manipulieren kann. Das habe ich dann auch mit Erfolg hinbekommen und es hat über Jahre problemlos gefunzt. Hier ein Beispiel, wie man das macht. Leider enthalten neuerdings immer weniger Programme echte Menüs. Immer häufiger werden Commandbars eingesetzt. Diese zu manipulieren, habe ich noch nicht probiert. Ist vielleicht ein zukünftiges Thema.

Beispieldatei (menu.zip 47 KB)

'########################################################
'# Eine Mappe mit dem Blattern Menü.
'# Eine Klasse mit dem Namen clsRunMenu.
'# Ein Modul
' ########################################################

'########################################################
'# In das Modul
'########################################################

Private Sub cmbHilfe()
Dim x As New clsRunMenu
    x.HilfeFensterliste
    x.HilfeParentWindow
    x.HilfeMenülisteAsArray
    x.HilfeMenülisteAsCollection
End Sub

Sub TestenNotepad()
Dim x As New clsRunMenu, m As Collection
Dim a, b, c As String, d As String
Dim i As Long, k As Long, l As Long
On Error Resume Next
'Liste aller Top-Level-Fenster!
'Im zweidimensionalen Array a ist
'1. Element Hwnd
'2. Element Titelleiste
'3. Element Klassenname
a = x.Fensterliste
With Worksheets("Menü")
    For i = 1 To UBound(a)
        'Suche nach Notepad
        If InStr(1, LCase(a(i, 3)), "notepad") Then
            'Fenster Notepad gefunden. Der Klasse die
            'Fensterzugriffsnummer übergeben
            x.AktuellesFensterHwnd = a(i, 1)
            'Zur Info den Titel und den Klassenname ausgeben
            c = x.AktuellesFensterCaption
            d = x.AktuellesFensterClassName
            MsgBox c & vbCrLf & d, _
                vbOK, "Menü ausgeben des folgenden Fensters"
            .Range("6:1000").Delete
            'Menüs als Array holen
            b = x.MenülisteAsArray
            .Range("C2") = x.AktuellesFensterCaption
            .Range("C3") = x.AktuellesFensterClassName
            .Range("C1") = x.AktuellesFensterHwnd
            For l = 1 To UBound(b)
                For k = 1 To 5
                    .Cells(l + 5, k) = b(l, k)
                Next
            Next
            'Menüs als Collection holen
'            Set m = x.MenülisteAsCollection
'            For l = 1 To m.Count
'                For k = 1 To 5
'                    .Cells(l + 3, k + 6) = m(l)(k)
'                Next
'            Next
        End If
    Next
End With
End Sub

'########################################################
'# Als Klasse clsRunMenu
'########################################################

Option Explicit
Private Declare Function GetMenu Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) _
    As Long
Private Declare Function GetMenuItemCount Lib "user32" _
    (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuString Lib "user32" _
    Alias "GetMenuStringA" _
    (ByVal hMenu As Long, ByVal wIDItem As Long, _
    ByVal lpString As String, ByVal nMaxCount As Long, _
    ByVal wFlag As Long) As Long
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 GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) 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 SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Integer, _
    ByVal lParam As Any) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
    Alias "SendMessageTimeoutA" (ByVal hwnd As Long, _
    ByVal msg As Long, ByVal wParam As Long, _
    ByVal lParam As String, ByVal fuFlags As Long, _
    ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Const SMTO_ABORTIFHUNG = &H2
Private Const WM_COMMAND = &H111
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private iHwnd As Long, iWindow, iParentWindow As Long

Private Function Durchlaufe(myHwnd As Long, _
    MyCol As Collection, _
    Optional myMenu As Long, _
    Optional myParentName As String, _
    Optional myActPath As String, _
    Optional myParentID As String)
Dim hwndHauptmenu As Long, hwndSubmenu As Long
Dim myName As String
Dim MenuID As String, MyEintrag(1 To 5) As String
Dim myAnzahl As Long, i As Long, myPfad As String
hwndHauptmenu = myMenu
If myMenu = 0 Then
    'Noch kein Menü ubergeben, deshalb holen
    hwndHauptmenu = GetMenu(myHwnd)
    'Keins gefunden, beeenden
    If hwndHauptmenu = 0 Then Exit Function
Else
    'Menü vorhanden
    If myActPath <> "" Then
        'Menü ist ein Submenü eines anderen
        myPfad = myActPath & "\"
        MyEintrag(3) = myPfad
        MyEintrag(5) = TrimTabUndKaufmännischesUnd(myPfad)
    Else
        'Menü ist kein Submenü
        myPfad = "\\" & myParentName & "\"
        MyEintrag(3) = "\\"
        MyEintrag(5) = "\\"
    End If
    'Infos in Array
    MyEintrag(1) = myParentID
    MyEintrag(2) = myParentName
    MyEintrag(4) = TrimTabUndKaufmännischesUnd(myParentName)
    'und der Collection übergeben
    MyCol.Add MyEintrag, "Eintrag_" & MyCol.Count
End If
myAnzahl = GetMenuItemCount(hwndHauptmenu)
'Alle Menüs auf dieser Ebene durchlaufen
For i = 0 To myAnzahl - 1
    'MenüID ermitteln
    MenuID = GetMenuItemID(hwndHauptmenu, i)
    myName = String(100, 0)
    'Menütext ermitteln
    GetMenuString hwndHauptmenu, i, myName, 100, MF_BYPOSITION
    myName = Left(myName, InStr(1, myName, Chr(0)) - 1)
    'Ermitteln, ob dieses Menü ein Submenü enthält
    hwndSubmenu = GetSubMenu(hwndHauptmenu, i)
    'Infos in Array
    MyEintrag(1) = MenuID
    MyEintrag(2) = myName
    MyEintrag(3) = myPfad & myName
    MyEintrag(4) = TrimTabUndKaufmännischesUnd(myName)
    MyEintrag(5) = TrimTabUndKaufmännischesUnd(myPfad & myName)
    If hwndSubmenu = 0 Then
        'Kein Submenü,
        'Array der Collection übergeben
        MyCol.Add MyEintrag, "Eintrag_" & MyCol.Count
    Else
        'Submenü vorhanden, diese Funktion für das Submenü
        'rekursiv durchlaufen
        Durchlaufe myHwnd, MyCol, hwndSubmenu, myName, myPfad, MenuID
    End If
Next
End Function

Public Sub Menüitem_anklicken(MenüID As Long)
SendMessageTimeout iHwnd, WM_COMMAND, MenüID, ByVal 0&, SMTO_ABORTIFHUNG, 5000, 0&
End Sub

Public Sub HilfeMenülisteAsArray()
Dim a As String
a = "Ein zweidimensionales Array mit Menüinfos wird geliefert." & vbCrLf
a = a & "Alle Menüs eines Fensters stecken darin." & vbCrLf
a = a & "In der zweiten Dimension das erste Element Array(i,1) = MenüID" & vbCrLf
a = a & "In der zweiten Dimension das zweite Element Array(i,2) = Menütext, wie er wirklich ist" & vbCrLf
a = a & " Beispiel:""&Neu"" & vbtab & ""Strg+N""" & vbCrLf
a = a & "In der zweiten Dimension das dritte Element Array(i,3) = MenüPfad, unbearbeitet" & vbCrLf
a = a & "In der zweiten Dimension das vierte Element Array(i,4) = Menütext, ohne &, bis zum Tab" & vbCrLf
a = a & " Beispiel:""Neu""" & vbCrLf
a = a & "In der zweiten Dimension das fünfte Element Array(i,5) = MenüPfad, bearbeitet" & vbCrLf
MsgBox a, vbOKOnly, "Hilfe zu MenülisteAsArray"
End Sub

Public Sub HilfeMenülisteAsCollection()
Dim a As String
a = a & "Alle Menüs eines Fensters stecken in der Collection." & vbCrLf
a = a & "Jedes Element der Collection enthalt ein Menü in Form eines eindimensionalen Arrays." & vbCrLf
a = a & "Im ersten Element des Arrays, Collection(i)(1) = MenüID" & vbCrLf
a = a & "Im zweiten Element des Arrays, Collection(i)(2) = Menütext, wie er wirklich ist" & vbCrLf
a = a & " Beispiel:""&Neu"" & vbtab & ""Strg+N""" & vbCrLf
a = a & "Im dritten Element des Arrays, Collection(i)(3) = MenüPfad, unbearbeitet" & vbCrLf
a = a & "Im vierten Element des Arrays, Collection(i)(4) = Menütext, ohne &, bis zum Tab" & vbCrLf
a = a & " Beispiel:""Neu""" & vbCrLf
a = a & "Im fünften Element des Arrays, Collection(i)(5) = MenüPfad, bearbeitet" & vbCrLf
MsgBox a, vbOKOnly, "Hilfe zu MenülisteAsCollection"
End Sub

Public Property Get MenülisteAsCollection() As Collection
'Es wird eine Menüliste als Collection erzeugt
Dim Col As New Collection
If iHwnd Then Durchlaufe iHwnd, Col
Set MenülisteAsCollection = Col
End Property

Public Property Get MenülisteAsArray() As Variant
'Es wird eine Menüliste als Collection erzeugt, und in ein
'normales Array umgewandelt. Die meisten Leute können
'bedauerlicherweise mit Collections nichts anfangen.
Dim Col As New Collection, MyArray(), i As Long, k As Long
On Error Resume Next
If iHwnd Then Durchlaufe iHwnd, Col
ReDim MyArray(1 To Col.Count, 1 To 5)
For i = 1 To Col.Count
    For k = 1 To 5
        MyArray(i, k) = Col(i)(k)
    Next
Next
MenülisteAsArray = MyArray
End Property

Public Property Get AktuellesFensterHwnd() As Long
'Die Zugriffsnummer des aktuellen Fensters liefern.
AktuellesFensterHwnd = iHwnd
End Property

Public Property Let AktuellesFensterHwnd(ByVal vNewValue As Long)
'Die Zugriffsnummer des aktuellen Fensters setzen.
'Es muss sich um eine aktuell gültige Zugriffsnummer handeln.
iHwnd = vNewValue
End Property

Public Property Get AktuellesFensterClassName() As String
'Aktuellen Klassenname liefern.
Dim d As Long, buffer As String
    buffer = String(256, 0)
    d = GetClassName(iHwnd, buffer, 255)
    AktuellesFensterClassName = Left(buffer, d)
End Property

Public Property Get AktuellesFensterCaption() As String
'Aktuellen Fenstertitel liefern.
Dim d As Long, buffer As String
    buffer = String(256, 0)
    d = GetWindowText(iHwnd, buffer, 255)
    AktuellesFensterCaption = Left(buffer, d)
End Property

Public Sub HilfeFensterliste()
Dim a As String
a = "Ein zweidimensionales Array mit Fensterinfos wird geliefert." & vbCrLf
a = a & "Alle Fenster einer Ebene, also alle mit dem selben Papa stecken darin." & vbCrLf
a = a & "In der zweiten Dimension das erste Element Array(i,1) = Fenster Hwnd" & vbCrLf
a = a & "In der zweiten Dimension das zweite Element Array(i,2) = Fenster Titelleiste" & vbCrLf
a = a & "In der zweiten Dimension das dritte Element Array(i,3) = Fenster Klassenname" & vbCrLf
MsgBox a, vbOKOnly, "Hilfe zu Fensterliste"
End Sub

Public Property Get Fensterliste() As Variant
'Eine Liste mit Fenstern liefern.
GetWindowlist
Fensterliste = iWindow
End Property

Public Sub HilfeParentWindow()
Dim a As String
a = "Auch Fenster haben Eltern und manchmal selbst Kinder." & vbCrLf
a = a & "Top-Level-Fenster haben als Papa den Desktop. Zugriffsnummer=0" & vbCrLf
a = a & "Alle anderen haben normale Fenster als Eltern." & vbCrLf
a = a & "Um Kindfenster zu suchen, muss hier das Elternfenster gesetzt werden." & vbCrLf
a = a & "Diese gefundenen Fenster können wiederum Kindfenster enthalten, usw."
MsgBox a, vbOKOnly, "Hilfe zu ParentWindow"
End Sub

Public Property Let ParentWindow(ByVal vNewValue As Long)
'Aktuelle Elternfensternummer setzen.
iParentWindow = vNewValue
End Property

Public Property Get ParentWindow() As Long
'Aktuelle Elternfensternummer liefern.
ParentWindow = iParentWindow
End Property

Private Sub GetWindowlist()
Dim a As New Collection, b(1 To 3), c As Long, d As Long
Dim buffer As String
'Eine Liste mit Fenstern, dessen Elternfenster iParentWindow ist,
'wird erzeugt. Wenn iParentWindow=0, dann alle Top-Level Fenster.
c = FindWindowEx(iParentWindow, c, vbNullString, vbNullString)
Do While c <> 0
    b(1) = c
    buffer = String(256, 0)
    'Fenstertitel
    d = GetWindowText(c, buffer, 255)
    b(2) = Left(buffer, d)
    buffer = String(256, 0)
    'Klassenname
    d = GetClassName(c, buffer, 255)
    b(3) = Left(buffer, d)
    'Zur Collection hinzu
    a.Add b, "Key" & b(1)
    c = FindWindowEx(iParentWindow, c, vbNullString, vbNullString)
Loop
ReDim iWindow(1 To a.Count, 1 To 3)
For d = 1 To a.Count
    iWindow(d, 1) = a(d)(1)
    iWindow(d, 2) = a(d)(2)
    iWindow(d, 3) = a(d)(3)
Next
End Sub

Private Function TrimTabUndKaufmännischesUnd(ByVal myText As String)
'Der Buchstabe "&" (der folgende Buchstabe wird unterstrichen dargestellt) wird entfernt.
'Nur bis zum Tab bleibt der Text, alles andere wird entfernt.
On Error Resume Next
    myText = Left(myText, InStr(1, myText, vbTab) - 1)
    Do While InStr(1, myText, "&")
        myText = Left(myText, InStr(1, myText, "&") - 1) _
            & Right(myText, Len(myText) - InStr(1, myText, "&"))
    Loop
    TrimTabUndKaufmännischesUnd = myText
End Function