Startseite / Tipps / VB 5/6-Tipp 0515: Fremde Menüs fernsteuern

VB 5/6-Tipp 0515: Fremde Menüs fernsteuern

 von Klaus Langbein

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdShow"
' Steuerelement: Schaltfläche "cmdRefresh"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "OptAction" (Index von 0 bis 2) auf Frame1
' Steuerelement: Textfeld "txtShell"
' Steuerelement: Schaltfläche "cmdShell"
' Steuerelement: Optionsfeld-Steuerelement "optMtype" (Index von 0 bis 1)
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "cmdRead"
' Steuerelement: Textfeld "txtHwnd"
' Steuerelement: Beschriftungsfeld "lblDescr" (Index von 0 bis 4)


' Autor: K. Langbein Klaus@ActiveVB.de
' Überarbeitet und Kommentiert von Thomas Rodemer (Thomas@ActiveVB.de)

' Die API bietet die Möglichkeit fremde Menüs auszulesen und die
' entsprechenden Handles und Identifier zu ermitteln. Wenn man diese
' erstmal hat kann man ganz diese Menüs auch ganz einfach fernsteuern.
' Leider werden Menüs, die Grafiken enthalten nicht erkannt. Weiß
' jemand Rat?

Private wDescr() As WindowDescr
Private LastProg As String

Option Explicit

Function EnabelControls(ByVal Index As Long)

    ' Je nachdem welche Option gewählt wurde, werden
    ' die dafür benötigten Felder und Schaltflächen freigeschaltet.
    Select Case Index
    
    Case 0
        Combo1.ListIndex = 0
        txtShell.Enabled = True
        txtShell.text = LastProg$
        txtHwnd.Enabled = False
        cmdShell.Enabled = True
        cmdRefresh.Enabled = False
        Combo1.Enabled = False
    Case 1
        
        txtShell.Enabled = False
        txtHwnd.Enabled = False
        cmdShell.Enabled = False
        cmdRefresh.Enabled = True
        Combo1.Enabled = True
    Case 2
        txtShell.Enabled = False
        txtHwnd.Enabled = True
        cmdShell.Enabled = False
        cmdRefresh.Enabled = True
        Combo1.Enabled = True
    End Select
    

End Function

Private Sub cmdRead_Click()
    
    ' Auslesen der verfügbaren Menüpunkte
    
    Dim menuCnt As Long
    Dim hmenu As Long
    Dim hWnd As Long
    Dim i As Long
    Dim n As Long
    Dim text As String
    ReDim MenuList(0)
    
    hWnd = Val(txtHwnd.text)
    List1.Clear
    If hWnd = 0 Then
        Exit Sub
    End If
      
    Call List_Menu(hWnd, hmenu, optMtype(0).Value) 'Die Funktion zum auslesen
                                                   'aufrufen
        
    For i = 1 To UBound(MenuList)
        n = (MenuList(i).level - 1) * 10
        If n < 0 Then
            n = 0
        End If
        text$ = String$(n, " ") + MenuList(i).text + "     ID" + Format(MenuList(i).Id)
        List1.AddItem text$                        ' Menüpunkte ausgeben
    Next i
    
End Sub


Private Sub cmdRefresh_Click()
    
    ' Diese Funktion aktualisiert den Inhalt von Combo1
    ' Der Inhalt von Combo1 sind alle Programme und Fenster, die
    ' zur Zeit offen sind. Markierung des Optionbuttons
    ' neben dem Button "Fensterliste" aktiviert die Auswahl durch
    ' Combo1.
    
    Dim i As Long
    
    Call GetWindowList(wDescr)  'Auslesen der verfügbaren Fenster
    Combo1.Clear
    Combo1.AddItem "-"
    Combo1.ItemData(Combo1.NewIndex) = 0
    For i = 1 To UBound(wDescr)
        If IsWindowVisible(wDescr(i).hWnd) <> 0 Then
            If wDescr(i).Title <> "" Then
                If GetSystemMenu(wDescr(i).hWnd, 0) > 0 Then
                    Combo1.AddItem (FileTitle(wDescr(i).ExeName)) & " -- " & wDescr(i).Title
                    Combo1.ItemData(Combo1.NewIndex) = i
                End If
            End If
        End If
    Next i
    Combo1.ListIndex = 0
End Sub

Private Sub cmdShell_Click()
    
    ' Startet ein Programm, das in txtShell angegeben wurde.
    ' Im Beispiel ist Notepad angegeben.
    
    Dim hWnd As Variant
    Dim i As Long
    Dim ix As Long
    
    LastProg = txtShell.text
    hWnd = GetShellHwnd(txtShell.text, 1)  'Starten des Programmes und übergabe
                                           'des hWnd
    txtHwnd = Format$(hWnd(LBound(hWnd)))
    Me.Show
    
    Call cmdRefresh_Click
    For i = 0 To Combo1.ListCount - 1
        ix = Combo1.ItemData(i)
        If wDescr(ix).hWnd = hWnd(0) Then
            Combo1.ListIndex = i
        End If
    Next i
    Call cmdRead_Click
        
End Sub


Private Sub cmdShow_Click()
    ' Diese Schaltfläche bringt das aktuell angewählte Fenster in
    ' den Vordergrund.
    
    If Val(txtHwnd.text) > 0 Then
        Call BringWindowToTop(Val(txtHwnd.text))
    End If
End Sub

Private Sub Combo1_Click()
    ' Wird ein Fenster ausgewählt, wird dieses als aktuelles
    ' Zielfenster benutzt.
    
    Dim i As Long
    Dim ix As Long
    ix = Combo1.ListIndex
    If ix > -1 Then
        i = Combo1.ItemData(ix)
        txtHwnd.text = wDescr(i).hWnd
        txtShell.text = wDescr(i).ExeName
        Call cmdRead_Click
    End If
End Sub


Private Sub Form_Load()
    LastProg = txtShell.text
    Call cmdRefresh_Click
    OptAction(0).Value = True
End Sub

Private Sub List1_DblClick()
    ' Wird auf einen Eintrag in der Liste mit den verfügbaren
    ' Menüeinträgen geklickt, wird dieser Befehl auch ausgeführt.
    ' Das Menü wird sozusagen ferngesteuert aufgerufen.
    
    Dim hWnd As Long
    Dim i As Long
    i = List1.ListIndex + 1
    hWnd = Val(txtHwnd.text)
    Call BringWindowToTop(hWnd)  ' Bringt das Zielfenster in den Vordergrund
    DoEvents
    If optMtype(1).Value = True Then ' Normales Menue oder Systemmenue?
        Call Msg_MenuClick(hWnd, MenuList(i).Id)
    Else
        Call Msg_SysMenuClick(hWnd, MenuList(i).Id)
    End If
End Sub


Private Sub OptAction_Click(Index As Integer)
    ' Je nachdem welche Option gewählt wurde, werden die
    ' dafür benötigten Felder und Schaltflächen freigeschaltet.
    Call EnabelControls(Index)
End Sub


Private Sub optMtype_Click(Index As Integer)
    ' Normales Menue oder Systemmenue auslesen?
    
    If Val(txtHwnd.text) > 0 Then
        Call cmdRead_Click
    End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "modRemotMenue" alias modRemoteMenue.bas  ---


' Autor: K. Langbein Klaus@ActiveVB.de
' Überarbeitet und Kommentiert von Thomas Rodemer (Thomas@ActiveVB.de)

' Die API bietet die Möglichkeit fremde Menüs auszulesen und die
' entsprechenden Handles und Identifier zu ermitteln. Wenn man diese
' erstmal hat kann man ganz diese Menüs auch ganz einfach fernsteuern.
' Leider werden Menüs, die Grafiken enthalten nicht erkannt. Weiß
' jemand Rat?

Option Explicit
Type Menu_Descriptor

    text As String
    Key As String
    Type As Long
    nSub As Long
    Id As Long
    ParenthMenu As Long
    ParentHwnd As Long
    level As Long
    pos As Long
    
End Type

Public Type WindowDescr

    hWnd As Long
    prid As Long
    Title As String
    Class As String
    ExeName As String
End Type


Public MenuList() As Menu_Descriptor

Public Const WM_CLOSE = &H10
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Const WM_DESTROY = &H2

Declare Function BringWindowToTop Lib "user32" ( _
                 ByVal hWnd As Long) 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 GetForegroundWindow Lib "user32" () As Long

Declare Function ShowWindow Lib "user32" ( _
                 ByVal hWnd As Long, _
                 ByVal nCmdShow As Long) As Long
                 
Declare Function GetWindowText Lib "user32" _
                 Alias "GetWindowTextA" ( _
                 ByVal hWnd As Long, _
                 ByVal lpstring As String, _
                 ByVal cch As Long) As Long
                 
Declare Function SendMessageByNum Lib "user32" _
                 Alias "SendMessageA" ( _
                 ByVal hWnd As Long, _
                 ByVal wMsg As Long, _
                 ByVal wparam As Long, _
                 lparam As Long) As Long
                 
Declare Function FindWindow Lib "user32" _
                 Alias "FindWindowA" ( _
                 ByVal lpClassName As String, _
                 ByVal lpWindowName As String) As Long
                 
Declare Function GetDeskTopWindow Lib "user32" _
                 Alias "GetDesktopWindow" () As Long
                 
Declare Function IsWindow Lib "user32" ( _
                 ByVal hWnd As Long) As Long
                 
Declare Function IsWindowVisible Lib "user32" ( _
                 ByVal hWnd As Long) As Long
                 
Declare Function GetWindowThreadProcessId Lib "user32" ( _
                 ByVal hWnd As Long, _
                 lpdwProcessId As Long) As Long
                 
Declare Function GetParent Lib "user32" ( _
                 ByVal hWnd As Long) As Long
                 
Declare Function GetTopWindow Lib "user32" ( _
                 ByVal hWnd As Long) As Long
                 
Declare Function GetWindow Lib "user32" ( _
                 ByVal hWnd As Long, _
                 ByVal wCmd As Long) As Long
                 
Declare Function GetWindowModuleFileName Lib "user32" _
                 Alias "GetWindowModuleFileNameA" ( _
                 ByVal hWnd As Long, _
                 ByVal pszFileName As String, _
                 ByVal cchFileNameMax As Long) As Long
                 
Declare Function GetMenuItemCount Lib "user32" ( _
                 ByVal hmenu As Long) As Long
                 
Declare Function GetMenuItemID Lib "user32" ( _
                 ByVal hmenu As Long, _
                 ByVal nPos As Long) As Long
                 
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
                 
Declare Function GetSubMenu Lib "user32" ( _
                 ByVal hmenu As Long, _
                 ByVal nPos As Long) As Long
                 
Declare Function GetMenu Lib "user32" ( _
                 ByVal hWnd As Long) As Long
                 
Declare Function GetMenuState Lib "user32" ( _
                 ByVal hmenu As Long, _
                 ByVal wID As Long, _
                 ByVal wFlags As Long) As Long
                 
Declare Function GetSystemMenu Lib "user32" ( _
                 ByVal hWnd As Long, _
                 ByVal bRevert As Long) As Long

Function FileTitle(ByVal fullname As String) As String
    Dim pos As Integer
    Dim i As Integer
    Dim l As Integer
    Dim t As String
    Dim tt As String
    
    l = Len(fullname)
    
    For i = l To 1 Step -1
        t = Mid$(fullname, i, 1)
        
        If t = "\" Then
            Exit For
        End If
    Next i
    
    If i > 0 Then
        t = Right$(fullname, l - i)
    Else
        t = fullname
    End If
    
    If Len(t) = 2 Then
        If Right$(t, 1) = ":" Then
            t = ""
        End If
    End If
    
    tt = Left$(t$, 1)
    If tt = "*" Or tt$ = "." Then
        t = ""
    End If
    
    FileTitle = t$
End Function

Sub Pause(ByVal pau As Single, ByVal doev As Integer)
    Dim t As Single
    t = Timer
    
    Do
        If doev = 1 Then
            DoEvents
        End If

    Loop Until (Timer - t) >= pau
End Sub

Function wintitle(ByVal handle As Long) As String
    ' Liest den Titel der Anwendung aus.
    Dim l As Long
    Dim buffer As String
    
    buffer = Space$(250)
    l = GetWindowText(handle, buffer, 250)
    wintitle = Left$(buffer, l)
End Function

Function winclass(ByVal handle As Long) As String
    ' Liest den Klassennamen aus.
    
    Dim l As Long
    Dim buffer As String
    buffer = Space$(250)
    
    l = GetClassName(handle, buffer, 250)
    winclass = Left$(buffer, l)
End Function
Function winExeName(ByVal handle As Long) As String

    ' Liest den vollständigen Pfad und den Exe-Dateinamen aus.
    Dim l As Long
    Dim buffer As String
    buffer = Space(250)
    
    l = GetWindowModuleFileName(handle, buffer, 250)
    
    If l > 0 Then
        buffer = Left$(buffer, l)
        If Right$(buffer, 1) = Chr$(0) Then
            winExeName = Left$(buffer, Len(buffer) - 1)
        Else
            winExeName = buffer
        End If
    End If
End Function
Function Msg_MenuClick(ByVal hand As Long, ByVal Id As Long) As Long
    
    ' Simuliert einen Klick auf den entsprechend vorher ausgewählten
    ' Menüeintrag.
    
    Dim ret As Long
    Const WM_COMMAND = &H111
    
    ret = SendMessageByNum(hand, WM_COMMAND, Id, 0&)

    Msg_MenuClick = ret
End Function
Function Msg_SysMenuClick(ByVal hand As Long, ByVal Id As Long) As Long
    
    ' Simuliert einen Klick auf den entsprechend vorher ausgewählten
    ' Systemmenüeintrag.

    Dim ret As Long
    Const WM_SYSCOMMAND = &H112
    
    ret = SendMessageByNum(hand, WM_SYSCOMMAND, Id, 0&)

    Msg_SysMenuClick = ret
End Function

Sub List_Menu(ByVal hWnd, ByVal hmenu As Long, sys As Long)

    ' Erstellt die Liste der Menüeinträge. Beachte:
    ' Die Funktion wird rekursiv verwendet, d.h. sie
    ' ruft sich selbst auf.
    
    Dim menuID As Long
    Dim menuFlag As Long
    Dim menuCnt As Long
    Dim i As Long
    Dim ret As Long
    Dim pos As Long
    Dim MenuText As String
    Dim mText As String
    Static level As Long
    Static cnt As Long
    Dim ub As Long
    Dim subMenu As Long
    Const MF_BYPOSITION = 1024
    Const MF_BYCOMMAND = 0
    
    If hmenu = 0 Then
        If sys = True Then
            hmenu = GetSystemMenu(hWnd, 0)
        Else
            hmenu = GetMenu(hWnd)
        End If
        cnt = 0
        level = 0
        MenuList(0).ParenthMenu = hmenu
    End If
    
    If hmenu <= 0 Then  ' Wenn nicht verfügbar > abbrechen
        Exit Sub
    End If
    
    menuCnt = GetMenuItemCount(hmenu)
    If menuCnt < 0 Then
        MsgBox "Error"
        Exit Sub
    End If
    
    ub = UBound(MenuList)
    ReDim Preserve MenuList(ub + menuCnt)
    level = level + 1
    
    MenuText = String$(256, 0)
  
    For i = 0 To menuCnt - 1
        ' ID für diese Menü lesen
        '  -1 für Popup, 0 für Seperator
        menuID = GetMenuItemID(hmenu, i)
        
        MenuText = String$(256, 0)
        Select Case menuID
            Case 0  ' Seperator
                cnt = cnt + 1
                MenuList(cnt).Type = 0
                mText$ = "---------------"
            Case -1 ' Popup menu
                cnt = cnt + 1
                MenuList(cnt).Type = 1
                ret = GetMenuString(hmenu, i, MenuText, 127, MF_BYPOSITION)
                menuFlag = GetMenuState(hmenu, i, MF_BYPOSITION)
                
            Case Else ' Normaler Eintrag
                cnt = cnt + 1
                ret = GetMenuString(hmenu, menuID, MenuText, 127, MF_BYCOMMAND)
                menuFlag = GetMenuState(hmenu, menuID, MF_BYCOMMAND)
                
                MenuList(cnt).Type = 2
          End Select
          
          If MenuList(cnt).Type > 0 Then
            pos = InStr(1, MenuText, Chr$(0), 1)
            mText = Left$(MenuText, pos - 1)
          End If
          MenuList(cnt).Id = menuID
          MenuList(cnt).ParentHwnd = hWnd
          MenuList(cnt).ParenthMenu = hmenu
          MenuList(cnt).text = mText
          MenuList(cnt).level = level
          MenuList(cnt).pos = i
                    
          If MenuList(cnt).Type = 1 Then
                subMenu = GetSubMenu(hmenu, i)
                menuCnt = GetMenuItemCount(subMenu)
                MenuList(cnt).nSub = menuCnt
                Call List_Menu(hWnd, subMenu, 0)
          End If
          
    Next i
    level = level - 1

End Sub

Function GetShellHwnd(ByVal ExeFile$, ByVal Wstyle As Long) As Variant

    ' Diese Funktion ruft ein Programm auf, liest dessen
    ' Fensterhandle aus und gibt es zurück.
    
    Dim wDescr() As WindowDescr
    Dim hh As Long
    Dim i As Long
    Dim prid As Long
    Dim cnt As Long
    Dim hWnd() As Long
    prid = Shell(ExeFile, Wstyle)
    Call Pause(0.1, 1)
       
    Call GetWindowList(wDescr())
    
    ReDim hWnd(0)
    For i = 1 To UBound(wDescr)
        
        If wDescr(i).prid = prid Then
            If wDescr(i).Class <> "tooltips_class" <> 0 Then
                hWnd(cnt) = wDescr(i).hWnd
                cnt = cnt + 1
                ReDim Preserve hWnd(cnt)
            End If
        End If
            
    Next i
    cnt = cnt - 1
    ReDim Preserve hWnd(cnt)
    GetShellHwnd = hWnd()
End Function

Sub GetWindowInfo(ByRef wDescr As WindowDescr)

    ' Liest Informationen des Zielfensters aus
    
    Dim buff As String
    Dim buff2 As String
    Dim buff3 As String
    Dim prid As Long
    Dim htask As Long
    Dim ub As Long
    Dim hParent As Long
    Dim PridA As Long
    
    prid = 0
    hParent = GetAncestor(wDescr.hWnd)
   
    PridA = GetWindowThreadProcessId(hParent, prid)
     
    wDescr.Title = wintitle(wDescr.hWnd)
    wDescr.Class = winclass(wDescr.hWnd)
    wDescr.ExeName = winExeName(wDescr.hWnd)
    wDescr.prid = prid
End Sub

Function GetWindowList(ByRef wDescr() As WindowDescr) As Long
    ' Diese Funktion sucht alle offenen Fenster.
    
    Dim i As Long
    Dim hh As Long
    
    hh = GetTopWindow(0&)
    ReDim wDescr(100)
    
    Do
        i = i + 1
        If i > UBound(wDescr) Then
            ReDim Preserve wDescr(UBound(wDescr) + 10)
        End If
        
        hh = GetWindow(hh, 2)
        If hh <> 0 Then
            wDescr(i).hWnd = hh
        End If
        Call GetWindowInfo(wDescr(i))
    Loop Until hh = 0
    
    ReDim Preserve wDescr(i)
    GetWindowList = i
End Function


Function GetAncestor(ByVal hWnd) As Long
    Dim hParent As Long
    Dim hw As Long
    hw = hWnd
    
    Do
        hParent = GetParent(hw)
        If hParent <> 0 Then
            hw = hParent
        End If
    Loop Until hParent = 0
    GetAncestor = hw
End Function
'--- Ende Modul "modRemotMenue" alias modRemoteMenue.bas  ---
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 7 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.