Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples4/ch10/menulook.frm

Visual Basic Form | 1997-02-16 | 22.5 KB | 637 lines

VERSION 4.00
Begin VB.Form Menulook
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   Caption         =   "Menulook demo program"
   ClientHeight    =   4020
   ClientLeft      =   1095
   ClientTop       =   1770
   ClientWidth     =   7365
   BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4710
   Left            =   1035
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   4020
   ScaleWidth      =   7365
   Top             =   1140
   Width           =   7485
   Begin VB.ListBox List1
      Appearance      =   0  'Flat
      Height          =   1785
      Left            =   240
      TabIndex        =   0
      Top             =   2160
      Width           =   6855
   End
   Begin VB.PictureBox Picture2
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   4440
      ScaleHeight     =   345
      ScaleWidth      =   1305
      TabIndex        =   6
      Top             =   1680
      Width           =   1335
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   495
      Left            =   3720
      Picture         =   "MENULOOK.frx":0000
      ScaleHeight     =   465
      ScaleWidth      =   465
      TabIndex        =   5
      Top             =   1560
      Width           =   495
   End
   Begin VB.CommandButton CmdAnalyze
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Analyze"
      Height          =   495
      Left            =   6000
      TabIndex        =   1
      Top             =   1140
      Width           =   1215
   End
   Begin VB.CommandButton CmdTrack
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "TrackPopup"
      Height          =   495
      Left            =   6000
      TabIndex        =   2
      Top             =   600
      Width           =   1215
   End
   Begin VB.CommandButton CmdEntry2Chk
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Entry2-Check"
      Height          =   495
      Left            =   4560
      TabIndex        =   8
      Top             =   600
      Width           =   1335
   End
   Begin VB.CommandButton CmdAddBitmap
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Add Bitmap"
      Height          =   495
      Left            =   6000
      TabIndex        =   4
      Top             =   60
      Width           =   1215
   End
   Begin VB.CommandButton CmdAddRandom
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "AddRandom"
      Height          =   495
      Left            =   4560
      TabIndex        =   7
      Top             =   60
      Width           =   1335
   End
   Begin VB.Label Label1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   1680
      Width           =   3255
   End
   Begin VB.Menu MenuTop
      Caption         =   "Menu1"
      HelpContextID   =   500
      Begin VB.Menu MenuEntry1
         Caption         =   "Entry1"
      End
      Begin VB.Menu MenuEntry2
         Caption         =   "Entry2"
      End
      Begin VB.Menu MenuEntry3
         Caption         =   "-"
      End
      Begin VB.Menu MenuArray1
         Caption         =   "Array1"
         Index           =   0
      End
      Begin VB.Menu MenuArray1
         Caption         =   "Array1B"
         Index           =   1
      End
      Begin VB.Menu MenuSubMenu1
         Caption         =   "SubMenu1"
         Begin VB.Menu MenuSub1Entry1
            Caption         =   "Sub1Entry1"
         End
         Begin VB.Menu MenuSub1Entry2
            Caption         =   "Sub1Entry2"
         End
      End
   End
   Begin VB.Menu MenuFloat
      Caption         =   "Floating"
      Begin VB.Menu MenuFloat1
         Caption         =   "Float1"
         Index           =   0
      End
      Begin VB.Menu MenuFloat1
         Caption         =   "Float2"
         Index           =   1
      End
   End
   Begin VB.Menu MenuRandomTop
      Caption         =   "Random"
      Begin VB.Menu MenuArt
         Caption         =   "Art1"
         Index           =   0
      End
   End
Attribute VB_Name = "Menulook"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved.
Dim IsWindows95 As Boolean
' This command adds the bitmap that is in the Picture1
' control to the Floating menu.
Private Sub CmdAddBitmap_Click()
#If Win32 Then
    Dim topmenuhnd&
    Dim floatmenu&
    Dim menuid&
#Else
    Dim topmenuhnd%
    Dim floatmenu%
    Dim menuid%
#End If
    Dim di&
    ' Get a handle to the top level menu
    topmenuhnd = GetMenu(Menulook.hwnd)
    ' And get a handle to the Floating popup menu.
    floatmenu = GetSubMenu(topmenuhnd, 1)
    ' If 3rd (bitmap) entry is already loaded, exit now
    ' (we only load the bitmap once)
    If GetMenuItemCount(floatmenu) >= 3 Then Exit Sub
    ' First, add a menu entry under VB - this provides us
    ' with a menu entry that can be replaced with a bitmap,
    ' but whose menu ID will be the same (so it will work
    ' properly
    Load MenuFloat1(2)
    ' Now get the ID of that entry
    menuid = GetMenuItemID(floatmenu, 2)
    If FloatBitmap = 0 Then FloatBitmap = CopyPictureImage(picture1)
    ' And replace it with a bitmap.
    di = ModifyMenuBynum(floatmenu, 2, MF_BITMAP Or MF_BYPOSITION, menuid, FloatBitmap)
End Sub
' This command creates a random bitmap and loads it into
' the Random popup menu.
Private Sub CmdAddRandom_Click()
#If Win32 Then
    Dim topmenuhnd&
    Dim floatmenu&
    Dim menuid&
    Dim newmenupos&
    Dim newbm&
#Else
    Dim topmenuhnd%
    Dim floatmenu%
    Dim menuid%
    Dim newmenupos%
    Dim newbm%
#End If
    Dim pw!, ph!
    Dim x%, di&
    ' First get the width and height of the picture2 control
    pw! = Picture2.ScaleWidth
    ph! = Picture2.ScaleHeight
    ' Get a handle to the Random popup menu
    topmenuhnd = GetMenu(Menulook.hwnd)
    floatmenu = GetSubMenu(topmenuhnd, 2)
    ' Find out how many menu items are already in the popup
    newmenupos = GetMenuItemCount(floatmenu)
    ' Load a VB menu entry at that position
    Load MenuArt(newmenupos)
    ' And get the MenuID for that entry
    menuid = GetMenuItemID(floatmenu, newmenupos)
    ' Draw some stuff on picture2
    Picture2.Cls
    For x% = 0 To 5 ' Random rectangles
        Picture2.Line (Rnd * pw!, Rnd * ph!)-(Rnd * pw!, Rnd * ph!), QBColor(CInt(Rnd * 15)), B
    Next x%
    ' Get a bitmap that is a copy of the picture2 control
    newbm = CopyPictureImage(Picture2)
    For x% = 0 To 32
        If BMHandles(x%) = 0 Then Exit For
    Next x%
    If x% = 32 Then ' No room to store the bitmap handle
        di = DeleteObject(newbm)
        Exit Sub
    End If
    BMHandles(x%) = newbm
    ' And place that bitmap in the menu
    di = ModifyMenuBynum(floatmenu, newmenupos, MF_BITMAP Or MF_BYPOSITION, menuid, newbm)
End Sub
'   Get the form's menu and analyze it.
Private Sub CmdAnalyze_Click()
#If Win32 Then
    Dim menuhnd&
#Else
    Dim menuhnd%
#End If
    ' Clear the listbox
    'dl& = SendMessage(List1.hwnd, LB_RESETCONTENT, 0, 0&)
    List1.Clear
    ' Get a handle to the top level menu for this window
    menuhnd = GetMenu(Menulook.hwnd)
    ' And analyze it
    ViewMenu menuhnd
End Sub
' Create a box checkmark bitmap for the Entry2 menu
Private Sub CmdEntry2Chk_Click()
#If Win32 Then
    Dim topmenuhnd&
    Dim floatmenu&
    Dim NewCheck&
#Else
    Dim NewCheck%
    Dim topmenuhnd%
    Dim floatmenu%
#End If
    Dim oldbkcolor&
    Dim di&
    ' Get the new checkmark bitmap
    NewCheck = GetNewCheck()
    ' Get a handle to the top level menu
    topmenuhnd = GetMenu(Menulook.hwnd)
    ' Get a handle to the first popup
    floatmenu = GetSubMenu(topmenuhnd, 0)
    ' And set the new check bitmap for the first (entry1) menu item
    di = SetMenuItemBitmaps(floatmenu, 1, MF_BYPOSITION, 0, NewCheck)
    ' Check the entry
    MenuEntry2.Checked = -1
    ' Remind the user to look at it.
    MsgBox "Look at the Menu1 - Entry2 menu"
End Sub
'   Hides the Floating menu entry in the caption,
'   and turns it into a tracked popup menu
Private Sub CmdTrack_Click()
#If Win32 Then  ' Port to correct handle type
    Dim topmenuhnd&
    Dim floatmenu&
#Else
    Dim topmenuhnd%
    Dim floatmenu%
#End If
    Dim oldcap$, di&
    Dim pt As POINTAPI
    ' Get a handle to the popup menu
    topmenuhnd = GetMenu(Menulook.hwnd)
    floatmenu = GetSubMenu(topmenuhnd, 1)
    ' Hide the menu entry by clearing the string
    ' temporarily. Note, don't make it invisible or the
    ' menu will go away!
    oldcap$ = MenuFloat.Caption
    MenuFloat.Caption = ""
    ' Find where the mouse cursor is and place the
    ' popup at that point
    GetCursorPos pt
    di = TrackPopupMenuBynum(floatmenu, TPM_CENTERALIGN, pt.x, pt.y, 0, Menulook.hwnd, 0&)
    ' Restore the original popup name
    MenuFloat.Caption = oldcap$
End Sub
'   This function makes a copy of the Image property bitmap
'   and returns a handle to that bitmap
Private Function CopyPictureImage(SourceImage As PictureBox) As Long
    Dim bm As BITMAP
    #If Win32 Then
    Dim newbm&
    Dim tdc&, oldbm&
    #Else
    Dim newbm%
    Dim tdc%, oldbm%
    #End If
    Dim di&
    ' First get the information about the image bitmap
    di = GetObjectAPI(SourceImage.Image, Len(bm), bm)
    bm.bmBits = 0
    ' Create a new bitmap with the same structure and size
    ' of the image bitmap
    newbm = CreateBitmapIndirect(bm)
    ' Create a temporary memory device context to use
    tdc = CreateCompatibleDC(SourceImage.hdc)
    ' Select in the newly created bitmap
    oldbm = SelectObject(tdc, newbm)
    ' Now copy the bitmap from the persistant bitmap in
    ' picture 2 (note that picture2 has AutoRedraw set TRUE
    di = BitBlt(tdc, 0, 0, bm.bmWidth, bm.bmHeight, SourceImage.hdc, 0, 0, SRCCOPY)
    ' Select out the bitmap and delete the memory DC
    oldbm = SelectObject(tdc, oldbm)
    di = DeleteDC(tdc)
    ' And return the new bitmap
    CopyPictureImage = newbm
End Function
' Clicking anywhere on the form triggers the CmdTrack command
' button.
Private Sub Form_Load()
#If Win32 Then
    Dim os As OSVERSIONINFO
    Dim di&
    Print "Click anywhere on the form to"
    Print "bring up a tracked popup menu"
    Randomize
    os.dwOSVersionInfoSize = Len(os)
    di = GetVersionEx(os)
    If os.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then IsWindows95 = True
#End If
    ' We never let IsWindows95 get set to True in 16 bits, because
    ' it is only used for Win32 specific APIs
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Clicking anywhere on the form triggers the CmdTrack button
    CmdTrack.value = -1
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim x%, di&
    ' If a new check bitmap was set, we need to destroy it
    ' otherwise the resources used by the bitmap will not
    ' be freed.
    If NewCheck <> 0 Then
        di = DeleteObject(NewCheck)
    End If
    ' The same applies to the random menu bitmaps
    For x% = 0 To 32
        If BMHandles(x%) <> 0 Then
            di = DeleteObject(BMHandles(x%))
        End If
    Next x%
    If FloatBitmap <> 0 Then
        Call DeleteObject(FloatBitmap)
    End If
End Sub
'   Gets a string containing a description of the flags
'   set for this menu item.
Private Function GetFlagString$(menuflags%)
    Dim f$
    If (menuflags% And MF_CHECKED) <> 0 Then
        f$ = f$ + "Checked "
    Else
        f$ = f$ + "Unchecked "
    End If
    If (menuflags% And MF_DISABLED) <> 0 Then
        f$ = f$ + "Disabled "
    Else
        f$ = f$ + "Enabled "
    End If
    If (menuflags% And MF_GRAYED) <> 0 Then f$ = f$ + "Grayed "
    If (menuflags% And MF_BITMAP) <> 0 Then f$ = f$ + "Bitmap "
    If (menuflags% And MF_MENUBARBREAK) <> 0 Then f$ = f$ + "Bar-break "
    If (menuflags% And MF_MENUBREAK) <> 0 Then f$ = f$ + "Break "
    If (menuflags% And MF_SEPARATOR) <> 0 Then f$ = f$ + "Seperator "
    GetFlagString$ = f$
End Function
' Create a custom bitmap checkmark and return a
' handle to that bitmap.
Private Function GetNewCheck&()
    Dim bm As BITMAP
    Dim pt As POINTS
    #If Win32 Then
    Dim newbm&
    Dim tdc&, oldbm&
    Dim br&, oldbrush&
    #Else
    Dim newbm%
    Dim tdc%, oldbm%
    Dim br%, oldbrush%
    #End If
    Dim markdims&
    Dim di&
    ' Find out how big the checkmark should be.
    markdims& = GetMenuCheckMarkDimensions()
    agDWORDto2Integers markdims&, pt.x, pt.y
    ' And create a magenta brush (the check mark will be
    ' a magenta filled rectangle
    br = CreateSolidBrush(QBColor(5))
    Picture2.Cls
    oldbrush = SelectObject(Picture2.hdc, br)
    ' Draw the rectangle.
    di = Rectangle(Picture2.hdc, 2, 2, pt.x - 2, pt.y - 2)
    di = SelectObject(Picture2.hdc, oldbrush)
    di = DeleteObject(br) ' Dump the brush.
    ' Create a compatible bitmap of the right size
    ' was: di% = GetObjectAPI(Picture2.Image, 14, agGetAddressForObject&(bm))
    di = GetObjectAPI(Picture2.Image, Len(bm), bm)
    bm.bmBits = 0
    bm.bmWidth = pt.x
    bm.bmHeight = pt.y
    newbm = CreateBitmapIndirect(bm)
    ' And create a memory device context to use
    tdc = CreateCompatibleDC(Picture2.hdc)
    oldbm = SelectObject(tdc, newbm)
    ' Copy in the new check mark
    di = BitBlt(tdc, 0, 0, pt.x, pt.y, Picture2.hdc, 0, 0, SRCCOPY)
    oldbm = SelectObject(tdc, oldbm)
    di = DeleteDC(tdc)
    GetNewCheck = newbm
End Function
' Let the system know this menu has been clicked
Private Sub MenuArray1_Click(Index As Integer)
    Label1.Caption = "Array1(" + Str$(Index) + ") selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuArt_Click(Index As Integer)
    Label1.Caption = "Menu Random Art (" + Str$(Index) + ") selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuEntry1_Click()
    ' Check or uncheck the menu each time it is clicked
    Label1.Caption = "Entry1 selected."
    MenuEntry1.Checked = Not MenuEntry1.Checked
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuEntry2_Click()
    ' Check or uncheck the menu each time it is clicked
    If MenuEntry2.Checked Then MenuEntry2.Checked = 0 Else MenuEntry2.Checked = -1
    Label1.Caption = "Entry2 selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuFloat_Click()
    Label1.Caption = "Floating selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuFloat1_Click(Index As Integer)
    Label1.Caption = "Float1(" + Str$(Index) + ") selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuRandomTop_Click()
    Label1.Caption = "Menu Random selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuSub1Entry1_Click()
    Label1.Caption = "Sub1Entry1 selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuSub1Entry2_Click()
    Label1.Caption = "Sub1Entry2 selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuSubMenu1_Click()
    Label1.Caption = "SubMenu1 selected."
End Sub
' Let the system know this menu has been clicked'
Private Sub MenuTop_Click()
    Label1.Caption = "MenuTop selected."
End Sub
'   This function loads into list1 an analysis of the
'   specified menu
Private Sub ViewMenu(ByVal menuhnd&)
    Dim menulen&
    Dim di&
#If Win32 Then
    Dim thismenu&
    Dim menuid&
    Dim currentpopup&
    Dim menuinfo As MENUITEMINFO
#Else
    Dim thismenu%
    Dim menuid%
    Dim currentpopup%
#End If
    Dim db%
    Dim menuflags%
    Dim flagstring$
    Dim menustring(128) As Byte
    Dim menustring2 As String * 128
    Dim context&
    ' This routine can analyze up to 32 popup sub-menus
    ' for each menu. We keep track of them here so that
    ' we can recursively analyze the popups after we
    ' analyze the main menu.
    Dim trackpopups&(32)
    currentpopup = 0
    List1.AddItem "Analysis of Menu handle# " & Hex$(menuhnd)
    ' Find out how many entries are in the menu.
    menulen = GetMenuItemCount(menuhnd)
    List1.AddItem "# of entries = " & Str$(menulen)
    #If Win32 Then
    context& = GetMenuContextHelpId(menuhnd)
    If context& > 0 Then List1.AddItem "Help Context ID = " & Str$(context&)
    #End If
    If IsWindows95 Then
        #If Win32 Then
            menuinfo.cbSize = Len(menuinfo)

            For thismenu = 0 To menulen - 1
                ' cch field is reset each time
                menuinfo.cch = 127
                menuinfo.dwTypeData = agGetAddressForObject(menustring(0))
                menuinfo.fMask = MIIM_DATA Or MIIM_ID Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_TYPE Or MIIM_CHECKMARKS

                ' Get the ID for this menu
                ' It's a command ID, -1 for a popup, 0 for a seperator
                di = GetMenuItemInfo(menuhnd, thismenu, True, menuinfo)
                If di = 0 Then
                    List1.AddItem "Entry #" + Str$(thismenu) + " is unaccessable via GetMenuItemInfo"
                Else
                    With menuinfo
                        ' Obtain all information about a menu
                        If .hSubMenu <> 0 Then
                            ' Save it in the list of popups
                            trackpopups&(currentpopup) = thismenu
                            currentpopup = currentpopup + 1
                            ' Why do we use left$?
                            List1.AddItem "Entry #" + Str$(thismenu) + " is a submenu. Handle = " + Hex$(.hSubMenu) + " is " + Left$(StrConv(menustring, vbUnicode), .cch)
                            List1.AddItem "Flags: " + GetFlagStringNew$(.fType, .fState)
                        Else
                            If .fType = MFT_STRING Then
                                List1.AddItem "Entry #" + Str$(thismenu) + " is a string = " + Left$(StrConv(menustring, vbUnicode), .cch)
                                List1.AddItem "Flags: " + GetFlagStringNew$(.fType, .fState)
                            Else
                                ' Menu type is a bitmap, or otherwise not supported by this application
                                List1.AddItem "Entry #" & Str$(thismenu) & " has flags: " + GetFlagStringNew$(.fType, .fState)
                            End If

                        End If

                    End With
                End If
            Next thismenu
        #End If
    Else
        For thismenu = 0 To menulen - 1
            ' Get the ID for this menu
            ' It's a command ID, -1 for a popup, 0 for a seperator
            menuid = GetMenuItemID(menuhnd, thismenu)
            Select Case menuid
                Case 0  ' It's a seperator
                    List1.AddItem "Entry #" + Str$(thismenu) + "is a seperator"
                Case -1 ' It's a popup menu
                    ' Save it in the list of popups
                    trackpopups&(currentpopup) = thismenu
                    currentpopup = currentpopup + 1
                    ' And report that it's here
                    db = GetMenuString(menuhnd, thismenu, menustring2, 127, MF_BYPOSITION)
                    menuflags = GetMenuState(menuhnd, thismenu, MF_BYPOSITION)
                    List1.AddItem "Entry #" + Str$(thismenu) + " is a submenu. Handle = " + Hex$(GetSubMenu(menuhnd, thismenu)) + " is " + Left$(menustring2, db)
                    List1.AddItem "Flags: " + GetFlagString$(menuflags)

                Case Else ' A regular entry
                    db = GetMenuString(menuhnd, menuid, menustring2, 127, MF_BYCOMMAND)
                    List1.AddItem "Entry #" + Str$(thismenu) + " cmd = " + Str$(menuid) + " is " + Left$(menustring2, db)
                    menuflags = GetMenuState(menuhnd, menuid, MF_BYCOMMAND)
                    List1.AddItem "Flags: " + GetFlagString$(menuflags)
            End Select
        Next thismenu
    End If
    If currentpopup > 0 Then ' At least one popup was found
        List1.AddItem "Sub menus:"
        For thismenu = 0 To currentpopup - 1
            menuid = trackpopups&(thismenu)
            ' Recursively analyze the popup menu.
            ViewMenu GetSubMenu(menuhnd, menuid)
        Next thismenu
    End If
End Sub
Public Function GetFlagStringNew$(ByVal fType&, ByVal fState&)
    Dim f$
    If (fState And MFS_CHECKED) <> 0 Then
        f$ = f$ + "Checked "
    Else
        f$ = f$ + "Unchecked "
    End If
    If (fState And MFS_DISABLED) <> 0 Then
        f$ = f$ + "Disabled "
    Else
        f$ = f$ + "Enabled "
    End If
    If (fState And MFS_GRAYED) <> 0 Then f$ = f$ + "Grayed "
    If (fType And MFT_BITMAP) <> 0 Then f$ = f$ + "Bitmap "
    If (fType And MFT_MENUBARBREAK) <> 0 Then f$ = f$ + "Bar-break "
    If (fType And MFT_RADIOCHECK) <> 0 Then f$ = f$ + "Radio "
    If (fType And MFT_MENUBREAK) <> 0 Then f$ = f$ + "Break "
    If (fType And MFT_SEPARATOR) <> 0 Then f$ = f$ + "Seperator "
    GetFlagStringNew$ = f$
End Function