World of Shareware - Software Farm 2/wosw_2.zip/wosw_2/PROG/CLAK20.ZIP/SAMPLE.ZIP/GENERAPP.FRM

Visual Basic Form | 1993-07-10 | 14.3 KB | 373 lines

VERSION 2.00
Begin Form Clacker_Form
   Caption         =   "Clacker Test"
   ClientHeight    =   4860
   ClientLeft      =   1215
   ClientTop       =   1830
   ClientWidth     =   5055
   Height          =   5550
   Left            =   1155
   LinkTopic       =   "Form1"
   ScaleHeight     =   4860
   ScaleWidth      =   5055
   Top             =   1200
   Width           =   5175
   Begin Clack Clacker1
      hwndForm        =   0
      Left            =   840
      Top             =   1200
   End
   Begin CommandButton BTN_Exit
      Caption         =   "Exit"
      Height          =   375
      Left            =   3720
      TabIndex        =   4
      Top             =   240
      Width           =   1215
   End
   Begin TextBox Text2
      Height          =   2655
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   3
      Text            =   "Text2"
      Top             =   840
      Width           =   4815
   End
   Begin CommandButton Btn_UnHook
      Caption         =   "UnHook"
      Height          =   375
      Left            =   1080
      TabIndex        =   1
      Top             =   240
      Width           =   1215
   End
   Begin CommandButton Btn_Hook
      Caption         =   "Hook"
      Height          =   375
      Left            =   2400
      TabIndex        =   2
      Top             =   240
      Width           =   1215
   End
   Begin TextBox TXT_MID
      Height          =   975
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   0
      Text            =   "Menu ID, menu not hooked"
      Top             =   3720
      Width           =   4815
   End
   Begin Menu nmu_File
      Caption         =   "&File"
      Begin Menu mnu_Exit
         Caption         =   "&Exit"
      End
   End
   Begin Menu mnu_Edit
      Caption         =   "&Edit"
      Begin Menu mnu_Cut
         Caption         =   "Cu&t"
      End
      Begin Menu mnu_Copy
         Caption         =   "&Copy"
      End
      Begin Menu mnu_Paste
         Caption         =   "&Paste"
      End
      Begin Menu mnu_submenu
         Caption         =   "SubMenu"
         Begin Menu mnu_submenu1
            Caption         =   "SubMenu 1"
         End
         Begin Menu mnu_submenu2
            Caption         =   "SubMenu 2"
         End
      End
   End
Option Explicit
Const CLACKER_START = 1
Const CLACKER_STOP = 2
Declare Function GetParent Lib "User" (ByVal hWnd As Integer) As Integer
Dim MenuStatus() As HelpTextType
Dim taContextHelp(1 To 25) As HelpTextType
Sub BTN_Exit_Click ()
    mnu_Exit_Click
End Sub
Sub Btn_Hook_Click ()
Dim Msg As String
Dim hWndParent As Integer
    'Msg = "hWnd HEX = " + Hex$(hWnd) + "    DECIMAL = " + Str$(hWnd) + Chr$(10) + Chr(13)
    'hWndParent = GetParent(hWnd)
    'Msg = Msg + "Parent of Me.hWnd HEX = " + Hex$(hWndParent) + "    DECIMAL = " + Str$(hWndParent)
    'MsgBox Msg
    Clacker1.hwndForm = Me.hWnd
    Clacker1.Action = CLACKER_START
    TXT_MID.Text = "Menu ID, menu hooked"
End Sub
Sub Btn_UnHook_Click ()
    Clacker1.hwndForm = Me.hWnd
    Clacker1.Action = CLACKER_STOP
    TXT_MID.Text = "Menu ID, menu not hooked"
End Sub
Sub Clacker1_ClackerClick (hMenu As Integer, MenuID As Integer, MenuCaption As String)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PURPOSE: Determine which menu was hit.
' COMMENTS: Clacker.vbx returns all the values shown from windows.
'           Read the SDK docs, to better understand Window's menu behavior.
' NOTES:    1. It is not necessary to make use of all of the return params.
'               Using only the MenuID is suffecient to retreive the stored text.
'           2. Clacker does not return a caption for all menu hits. Windows does
'               not provide return captions for typically unused menu items,
'               ie, those which are processed by Window's default menuprocs.
'           3. Separators return MenuID = 0 for all of them.
'           4. Top level menus and submenus return hMenu = MenuID.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Msg As String
Dim ndex As Integer
Dim lMenuID As Long, lhMenu As Long
If MenuID = -1 Then Stop
If hMenu = -1 Then Stop
    If MenuID < -1 Then
        'change Menu ID to faked USHORT
        lMenuID = MenuID + 65536
    Else
        lMenuID = MenuID
    End If
    If hMenu < -1 Then
        'change Menu ID to faked USHORT
        lhMenu = hMenu + 65536
    Else
        lhMenu = hMenu
    End If
    '
    ' debugging output
    Msg = ""
    Msg = Msg + "hMenu  hex = " + Hex$(lhMenu) + Chr$(13) + Chr$(10)
    Msg = Msg + "MenuID hex = " + Hex$(lMenuID) + Chr$(13) + Chr$(10)
    If Len(MenuCaption) <> 0 Then
        Msg = Msg + "MenuCaption  " + MenuCaption + Chr$(13) + Chr$(10)
    Else
        Msg = Msg + "MenuCaption  [none returned]" + Chr$(13) + Chr$(10)
    End If
    Debug.Print Msg
    '
    ' user output
    ' search for the MenuID, get the assigned help text and display it.
    For ndex = 1 To 20
        If MenuStatus(ndex).lMenuID = lMenuID Then
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' IMPORTANT NOTE:
            ' A BOGUS MenuID was initially stored in the top menu spot
            ' The real hMenu of a top level menu shows up here
            ' You can sub the bogus for the real one if desired.
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            If MenuStatus(ndex).lhMenu <> lhMenu Then
              '
              ' see if it is the BOGUS MenuID
              '
              If MenuStatus(ndex).lhMenu <> lMenuID Then
                Msg = "Bad stored hMenu" + Chr$(13) + Chr$(10)
                Msg = Msg + "Stored hMenu = " + Hex$(MenuStatus(ndex).lhMenu) + Chr$(13) + Chr$(10)
                Msg = Msg + "Return hMenu = " + Hex$(lhMenu) + Chr$(13) + Chr$(10)
                Msg = Msg + "return MenuID= " + Hex$(lMenuID) + Chr$(13) + Chr$(10)
                Debug.Print Msg
              Else
                Debug.Print "Bogus top level menu was stored here"
              End If
            End If
            Msg = "MenuID = " + Hex$(lMenuID) + Chr$(13) + Chr$(10)
            Msg = Msg + "hMenu = " + Hex$(hMenu) + Chr$(13) + Chr$(10)
            Msg = Msg + "Help Msg Text = " + MenuStatus(ndex).strHelpMsg + Chr$(13) + Chr$(10)
            If Len(MenuCaption) <> 0 Then
                Msg = Msg + "Menu Caption = " + MenuCaption + Chr$(13) + Chr$(10)
            Else
                Msg = Msg + "Menu Caption = [No Caption returned]" + Chr$(13) + Chr$(10)
            End If
            TXT_MID.Text = Msg
            Msg = "Found It " + Msg
            Debug.Print Msg
            Exit Sub
        End If
    Next
End Sub
Sub Form_Load ()
Dim hSysMenu As Integer
Dim hMainMenu As Integer
Dim Msg As String
Dim ndex As Integer
    Top = 0
    Left = 0
    '' how many menu items
    ' system
    hSysMenu = GetSystemMenu(Me.hWnd, False)
    ' main menu
    hMainMenu = GetMenu(Me.hWnd)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' IMPORTANT NOTE:
    '   The MenuStatus array size must be equal to or great than the total
    '   number of menu items in the form, or else a bounds error will occur.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim MenuStatus(1 To 25) As HelpTextType
    '' fill the array with their ids
    ' first the system menu
    Debug.Print "Setup hSysMenu"
    MenuSetup hSysMenu
    ' now the main menu
    ' start where the sysmenu ends
    Debug.Print "Setup hMainMenu"
    MenuSetup hMainMenu
    '
    '
    ' set up help text
    MenuHelpText
    ' Print all menu IDs to a dialog
    Msg = ""
    Msg = Msg + "Me.hWnd HEX = " + Hex$(hWnd) + "    DECIMAL = " + Str$(hWnd) + Chr$(13) + Chr$(10)
    Msg = Msg + "hSysMenu  =" + Hex$(hSysMenu) + Chr$(13) + Chr$(10)
    Msg = Msg + "hMainMenu =" + Hex$(hMainMenu) + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)
    For ndex = 1 To 20
        Msg = Msg + "Index = " + Str$(ndex) + Chr$(13) + Chr$(10)
        Msg = Msg + "hMenu = " + Hex$(MenuStatus(ndex).lhMenu) + Chr$(13) + Chr$(10)
        Msg = Msg + "MID = " + Hex$(MenuStatus(ndex).lMenuID) + Chr$(13) + Chr$(10)
        Msg = Msg + "Help Text    = " + MenuStatus(ndex).strHelpMsg + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)
    Next
    Text2.Text = Msg
End Sub
Sub Form_Resize ()
    If Me.WindowState = 0 Then
        Me.Height = 5550
        Me.Width = 5175
    End If
End Sub
Sub Form_Unload (Cancel As Integer)
    Clacker1.hwndForm = Me.hWnd
    Clacker1.Action = CLACKER_STOP
End Sub
Sub MenuHelpText ()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  PURPOSE: Load the help text string in the array.
' COMMENTS: Make sure you provide an entry for each menu in your
'           menu system, even if it won't be used. This helps when
'           laying out the help system and with debugging.
'    NOTES: 1. To conserve stack space in the main module
'               place the text strings and the array in another module
'           2. The MenuStatus array size must be equal to or great than the total
'               number of menu items in the form, or else a bounds error will occur.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    MenuStatus(1).strHelpMsg = "<System Menu>"
    MenuStatus(2).strHelpMsg = "Restore previous window position"
    MenuStatus(3).strHelpMsg = "Move the current window Window"
    MenuStatus(4).strHelpMsg = "Change the size of current Window"
    MenuStatus(5).strHelpMsg = "Minimize current Window"
    MenuStatus(6).strHelpMsg = "Maximize current Window"
    MenuStatus(7).strHelpMsg = "[separator]"        '[separator], no MenuID and no text
    MenuStatus(8).strHelpMsg = "Close current Window"
    MenuStatus(9).strHelpMsg = "[separator]"        '[separator], no MenuID and no text
    MenuStatus(10).strHelpMsg = "Switch to different task"
    MenuStatus(11).strHelpMsg = "<Main Form Menu>"
    MenuStatus(12).strHelpMsg = "<File Menu>"
    MenuStatus(13).strHelpMsg = "Exit the program"
    MenuStatus(14).strHelpMsg = "<Edit Menu>"
    MenuStatus(15).strHelpMsg = "Cut selected text from document"
    MenuStatus(16).strHelpMsg = "Copy selected text to clipboard"
    MenuStatus(17).strHelpMsg = "Paste clipboard text into document"
    MenuStatus(18).strHelpMsg = "Main Submenu text"
    MenuStatus(19).strHelpMsg = "Submenu1 text message"
    MenuStatus(20).strHelpMsg = "Submenu2 text message"
End Sub
Sub MenuSetup (hMenu As Integer)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  PURPOSE: Save the menu item ID information into the passed array
' COMMENTS: MenuSetup() is called recursively to load sub-menus
'    NOTES: 1. The MenuStatus array size must be equal to or great than the total
'              number of menu items in the form, or else a bounds error will occur.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim nItemCount As Integer
Dim lMenuID, lMenu As Long
Dim nItemPos As Integer
Dim nResult As Integer
Dim nMenuID As Integer
Static nElement As Integer  ' Static for pointer locating the last element inserted
Debug.Print "New hMenu = "; Hex$(hMenu)
Debug.Print
    nItemPos = 0
    nElement = nElement + 1
    '
    '
    ' store the top most menu
    If hMenu < -1 Then
        'change Menu ID to a faked USHORT
        lMenu = hMenu + 65536
    Else
        lMenu = hMenu
    End If
    MenuStatus(nElement).lhMenu = lMenu
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' IMPORTANT NOTE:
    ' Store the hMenu in the menuID spot as a FLAG
    ' The MenuID returned from Clacker WILL NOT MATCH THIS
    ' Clacker will return the real top level hMenu from windows.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    lMenuID = hMenu
    MenuStatus(nElement).lMenuID = lMenuID
    Debug.Print "nItemPos = "; nItemPos
    Debug.Print "nElement = "; nElement
    Debug.Print "MenuStatus(nElement).nMenuID = "; Hex$(MenuStatus(nElement).lMenuID)
    Debug.Print "MenuStatus(nElement).lhMenu   = "; Hex$(MenuStatus(nElement).lhMenu)
    Debug.Print
    nItemCount = GetMenuItemCount(hMenu)
    For nItemPos = 0 To nItemCount - 1
        ' Enumerate all sub-menus
        ' each sub menu starts at zero
        ' the menu id for this position
        nMenuID = GetMenuItemID(hMenu, nItemPos)
        If nMenuID = -1 Then
            '
            ' if the first item is -1
            '   it's a submenu ( cascade menu )
            nMenuID = GetSubMenu(hMenu, nItemPos)
            '
            ' since it is a submenu need to
            ' call this function recursively
            Debug.Print "Recurse"
            MenuSetup nMenuID
        Else
            '
            'normal menu item, save the menu item ID
            '
            ' bump the position so we start at 2,
            '   after the first hMenu is added
            nElement = nElement + 1
            ' Menu ID is a USHORT type, but VB has none so,
            ' change Menu ID to unsigned short as required for saving
            ' and later matching the return value from Clacker
            If nMenuID < -1 Then
                'change Menu ID to a faked USHORT
                lMenuID = nMenuID + 65536
            Else
                lMenuID = nMenuID
            End If
            '
            ' Put a menu item in the array
            MenuStatus(nElement).lMenuID = lMenuID
            MenuStatus(nElement).lhMenu = hMenu

            Debug.Print "nItemPos = "; nItemPos
            Debug.Print "nElement = "; nElement
            Debug.Print "MenuStatus(nElement).nMenuID = "; Hex$(MenuStatus(nElement).lMenuID)
            Debug.Print "MenuStatus(nElement).lhMenu   = "; Hex$(MenuStatus(nElement).lhMenu)
            Debug.Print
        End If
    Next
End Sub
Sub mnu_Exit_Click ()
    '
    ' process cannot terminate with menus still hooked to dll
    Clacker1.hwndForm = Me.hWnd
    Clacker1.Action = CLACKER_STOP
    End
End Sub