form1.frm

带图标的菜单,API

      End
      Begin VB.Menu mnuList 
         Caption         =   "&Lijst"
      End
      Begin VB.Menu mnuDetails 
         Caption         =   "&Details"
      End
   End
   Begin VB.Menu MnuSett 
      Caption         =   "&Menu2"
      Begin VB.Menu mnuSave 
         Caption         =   "&Opslaan"
      End
      Begin VB.Menu MnuDiscard 
         Caption         =   "&Herladen"
      End
      Begin VB.Menu mnuLine3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuClose 
         Caption         =   "&Sluiten"
      End
   End
   Begin VB.Menu mnuRun 
      Caption         =   "&Menu3"
      Begin VB.Menu mnuCancel 
         Caption         =   "&Annuleren"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuLine9 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPause 
         Caption         =   "Animatie &Onderbreken"
      End
   End
   Begin VB.Menu Menu4 
      Caption         =   "Menu4"
      Begin VB.Menu mnuHide 
         Caption         =   "&Verbergen"
      End
      Begin VB.Menu mnuLine 
         Caption         =   "-"
      End
      Begin VB.Menu mnuCloseApp 
         Caption         =   "&Afsluiten"
      End
   End
End
Attribute VB_Name = "frmOwnMnu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim pnt As PaintEffects

Dim MyFont As Long
Dim OldFont As Long

Dim wlOldProc As Long

Dim Caps(2 To 27) As String

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Private Sub Command1_Click()
MsgBox "Works fine!" & Chr(10) & "But probably the Call DeleteObject(MyFont) may cause some errors. Disable it when buidling", vbInformation
End Sub

Private Sub Form_Load()

     Set pnt = New PaintEffects

     Caps(2) = "Help"
     Caps(3) = ""
     Caps(4) = "Message"
     Caps(5) = ""
     Caps(6) = "Settings"
     Caps(7) = "Communication"
     Caps(8) = ""
     Caps(9) = "Exit                 (ALT+F4)"
     
     Caps(11) = "Large Icons"
     Caps(12) = "Small Icons"
     Caps(13) = "List"
     Caps(14) = "Details"
     
     Caps(16) = "Save"
     Caps(17) = "Discard"
     Caps(18) = ""
     Caps(19) = "Close Object"
     
     Caps(21) = "Cancel"
     Caps(22) = ""
     Caps(23) = "Break"
     
     Caps(25) = "Hide"
     Caps(26) = ""
     Caps(27) = "Close"
     
     '
     ' While buidling your app, disable the next line (No icons in the menu!) this will save you application from crashing while
     ' debuging. (Probably you can and a registry entry (DWORD) NoGraphicalMenu) Usefull!.
     '
     enableIcons
     
     Me.mnuPause.Enabled = False
     Me.mnuSmallIcon.Checked = True
     Me.mnuMessage.Checked = True
     Me.mnuOver.Checked = True
     Me.mnuSettings.Enabled = False

End Sub
Public Function MsgProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'This procedure is called because we've subclassed
'this form. We will catch DRAWITEM and MEASUREITEM
'messages and pass the rest of them on.

'Various structs we'll need
Dim MeasureInfo As MEASUREITEMSTRUCT
Dim DrawInfo As DRAWITEMSTRUCT
Dim mii As MENUITEMINFO
'Set later for separator flag:
Dim IsSep As Boolean
'Our custom brush and the old one
Dim hBr As Long, hOldBr As Long
'Our custom pen and the old one
Dim hPen As Long, hOldPen As Long
'The text color of the menu items
Dim lTextColor As Long
'Now much to bump the menu's selection
'rectangle over
Dim iRectOffset As Integer
Dim isChecked As Boolean

If wMsg = WM_DRAWITEM Then
     If wParam = 0 Then 'It was sent by the menu
          'Get DRAWINFOSTRUCT -- copy it to our
          'empty structure from the pointer in lParam
          Call CopyMem(DrawInfo, ByVal lParam, LenB(DrawInfo))
          IsSep = IsSeparator(DrawInfo.itemID)

          '===Set the menu font through its hDC...===
          MyFont = SendMessage(Me.hWnd, WM_GETFONT, 0&, 0&)
          OldFont = SelectObject(DrawInfo.hdc, MyFont)
          'We draw the item based on Un/Selected:
        
          'Some constants can be interpeted as others
          
          Select Case DrawInfo.itemState
          
                Case 257, 289
                    DrawInfo.itemState = ODS_SELECTED

                Case 9, 297
                    DrawInfo.itemState = 265
                    
                Case 294, 295, 6
                    DrawInfo.itemState = 262
                    
                Case 7
                    DrawInfo.itemState = 263
                    
                Case 303, 302
                    DrawInfo.itemState = 270
                    
                Case 296
                    DrawInfo.itemState = 264
                    
                Case 14, 15
                    DrawInfo.itemState = 271

          End Select
          
          Select Case DrawInfo.itemState
          
            Case ODS_SELECTED, 265, 263
               hBr = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
               hPen = GetPen(1, GetSysColor(COLOR_HIGHLIGHT))
               lTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
               
            Case Else
               hBr = CreateSolidBrush(GetSysColor(COLOR_MENU))
               hPen = GetPen(1, GetSysColor(COLOR_MENU))
               lTextColor = GetSysColor(COLOR_MENUTEXT)
               
          End Select
          
          'We're going to draw on the menu
          QuickGDI.TargethDC = DrawInfo.hdc
          'Select our new, correctly colored objects:
          
          hOldBr = SelectObject(DrawInfo.hdc, hBr)
          hOldPen = SelectObject(DrawInfo.hdc, hPen)
          
          With DrawInfo.rcItem
            
            Select Case DrawInfo.itemState
            
            Case 263, ODS_SELECTED, 265
                   'Not these
            Case Else
                   'Clear the space where the image is
                   QuickGDI.DrawRect .Left, .Top, 22, .Bottom
            End Select
          
            'Check to see if the menu item is one of the
            'ones with a picture. If so, then we need to
            'move the edge of the drawing rectangle a little
            'to the left to make room for the image.
            iRectOffset = IIf(img(DrawInfo.itemID).picture <> 0, 23, 0)
            'Do we have a separator bar?
          
            If Not IsSep Then
                'Draw the rectangle onto the item's space
                QuickGDI.DrawRect .Left + iRectOffset, .Top, .Right, .Bottom
                'Print the item's text
                '(held in the Caps() array)
                Select Case DrawInfo.itemState
                
                Case 271, 270, 262 'Disabled
                    lTextColor = GetSysColor(COLOR_WINDOW)
                    hPrint .Left + 25, .Top + 3, " " & Caps(DrawInfo.itemID), lTextColor
                    lTextColor = GetSysColor(COLOR_GRAYTEXT)
                    hPrint .Left + 24, .Top + 2, " " & Caps(DrawInfo.itemID), lTextColor
                    
                Case 263
                    lTextColor = GetSysColor(COLOR_GRAYTEXT)
                    hPrint .Left + 24, .Top + 2, " " & Caps(DrawInfo.itemID), lTextColor
                
                Case Else ' Object is enabled
                    hPrint .Left + 24, .Top + 2, " " & Caps(DrawInfo.itemID), lTextColor
                                        
                End Select
            End If
          End With
          
          'Select the old objects into the menu's DC
          Call SelectObject(DrawInfo.hdc, hOldBr)
          Call SelectObject(DrawInfo.hdc, hOldPen)
          
          'Delete the ones we created
          Call DeleteObject(hBr)
          Call DeleteObject(hPen)
          
          
          With DrawInfo
            'If the item had an image:
            If img(.itemID).picture.Handle <> 0 Then
            
               'If this item is selected, draw a raised
               'box around the image
               
               Select Case DrawInfo.itemState
               
               Case 262
                    Call buildEmbosedImage(img(.itemID))
               
               Case 263
                     Call buildEmbosedImage(img(.itemID))
                     ThreedBox 1, .rcItem.Top, 21, .rcItem.Bottom - 1, False
                    
               Case 271, 270
               
                     ThreedBox 1, .rcItem.Top, 21, .rcItem.Bottom - 1, True
                     Call buildEmbosedImage(img(.itemID))
                                                  
               Case 265, 264, 8
               
                     ThreedBox 1, .rcItem.Top, 21, .rcItem.Bottom - 1, True
                     Call removeEmbosedImage(img(.itemID))
                    
               Case ODS_SELECTED
               
                     ThreedBox 1, .rcItem.Top, 21, .rcItem.Bottom - 1, False
                     Call removeEmbosedImage(img(.itemID))
                     
               Case Else
            
                    Call removeEmbosedImage(img(.itemID))
                    
               End Select
               
               If Not img(.itemID).Tag = "Embosed" Then
                pnt.PaintTransparentStdPic .hdc, 4, .rcItem.Top + 2, 16, 16, img(.itemID).picture, 0, 0, &HC0C0C0
               Else
                tmpPicture.picture = img(.itemID).Image
                pnt.PaintTransparentStdPic .hdc, 4, .rcItem.Top + 2, 16, 16, tmpPicture.picture, 0, 0, &HC0C0C0
               End If
          Else
          
          '
          ' The box is checked, but there is no image, so draw the V
          '
          
            Select Case DrawInfo.itemState
            
            Case 264, 8
                
                ThreedV 1, .rcItem.Top, 21, .rcItem.Bottom - 1, False
                
            Case 265
                ThreedV 1, .rcItem.Top, 21, .rcItem.Bottom - 1, True
                                        
            End Select
          End If
            
          If IsSep Then
               'Draw the special separator bar
               ThreedBox .rcItem.Left, .rcItem.Top + 2, .rcItem.Right - 1, .rcItem.Bottom - 2, True
          End If
          End With
     End If
     'Don't pass this message on:
     MsgProc = False
     
     Exit Function
     

ElseIf wMsg = WM_MEASUREITEM Then
     'Get the MEASUREITEM struct from the pointer
     Call CopyMem(MeasureInfo, ByVal lParam, Len(MeasureInfo))
     IsSep = IsSeparator(MeasureInfo.itemID)
     'Tell Windows how big our items are.
     MeasureInfo.itemWidth = 140
     'If the item being measured is the separator
     'bar, the height should be 5 pixels, 18 if
     'otherwise...
     MeasureInfo.itemHeight = IIf(IsSep, 5, 20)
     'Return the information back to Windows
     Call CopyMem(ByVal lParam, MeasureInfo, Len(MeasureInfo))
     'Don't pass this message on:
     MsgProc = False
     Exit Function

End If

'We didn't handle this message,
'pass it on to the next WndProc
MsgProc = CallWindowProc(wlOldProc, hWnd, wMsg, wParam, lParam)

End Function


Private Sub enableIcons()
     If wlOldProc <> 0 Then Exit Sub

     Dim i As Integer

     MenuItems.MenuForm = Me
     
     'Start with File menu
     MenuItems.SubMenu = 0
     
     For i = 0 To 7
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     
     'Next comes 2nd menu...
     MenuItems.SubMenu = 1
     For i = 0 To 4
          MenuItems.MenuID = i
           OwnerDrawMenu (i + 2)
     Next
     
     'Next comes 3th menu...
     MenuItems.SubMenu = 2
     For i = 0 To 4
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     
     'Next comes 4th menu...
     MenuItems.SubMenu = 3
     For i = 0 To 3
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
     
     'Next comes 5th menu...
     MenuItems.SubMenu = 4
     For i = 0 To 3
          MenuItems.MenuID = i
          OwnerDrawMenu (i + 2)
     Next
 
     wlOldProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf OwnMenuProc)

End Sub

Private Sub Form_Unload(Cancel As Integer)
     If wlOldProc <> 0 Then
          SetWindowLong hWnd, GWL_WNDPROC, wlOldProc
     End If
     Set pnt = Nothing

     'Destroy the font object created in
     'the form's window procedure.
     '
     Call DeleteObject(MyFont)

End Sub