近日见到广大的爱好者对菜单或各个控件的样式和效果产生很多的问题，于是就把自己所写的菜单类加上大量的注释，希望帮助大家能明白到其实各种多姿多彩的控件究竟是怎样生成的，其实最主要的就是把控件标志为自绘就行了然后就到自己绘制这个控件，而可以定为“自绘”的控件有LISTBOX，TEXT，LABEL，LISTVIEW，TAB，MENU等等，而且自要学会了自绘菜单的话要完成像OUTLOOK那样的界面就马上变得一点难度都没有了（其实也还是有一点点的）好了废话小说现在就开始自绘的旅程吧

发表于: 2004-07-27 at 22:53 | IP已记录

标准模块里：Option Explicit
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Public Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Type LOGBRUSH '画册信息的结构
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
End Type
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Type DRAWITEMSTRUCT '自绘菜单的绘图（控件）结构，另外由于它在VC里面是指向这个结构的菜单，所以在VB里面要用到CopyMemory这个API函数
        CtlType As Long
        CtlID As Long
        ItemID As Long
        itemAction As Long
        itemState As Long
        hwndItem As Long
        hdc As Long
        rcItem As RECT
        itemData As Long
End Type
Public Type MEASUREITEMSTRUCT '自绘菜单时候获取菜单的大小（自定义）
        CtlType As Long
        CtlID As Long
        ItemID As Long
        itemWidth As Long
        itemHeight As Long
        itemData As Long
End Type
Public Const GWL_STYLE = (-16)
Public Const DT_CENTER = &H1 '文字显示的方式
Public Const DT_RIGHT = &H2 '同上
Public Const DT_SINGLELINE = &H20 '同上
Public Const DT_VCENTER = &H4 '同上
Public Const DT_LEFT = &H0 '同上
Public Const GWL_WNDPROC = (-4)
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
Public Const WM_MOUSEMOVE = &H200
Public Const LR_LOADFROMFILE = &H10
Public Const IMAGE_BITMAP = 0
Public Const IMAGE_ICON = 1
Public Const SRCCOPY = &HCC0020  ' (DWORD) dest = source
Public MyPoint As POINTAPI
Public Menu As New CMenu '把自绘菜单类对象化
Public List As New CList
Public OldWinProc As Long
Public a As String
Public Sub CallWinProc() '把窗口消息交给自己处理（NewWinProc)
OldWinProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf NewWinProc)
End Sub
Public Function NewWinProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '自定义窗口过程（处理消息）
  Select Case Msg
    Case WM_DRAWITEM
      Menu.OnDrawItem lParam
      List.OnDrawItem lParam
      Exit Function
    Case WM_MEASUREITEM
      Menu.OnMeasureItem lParam
      Exit Function
  End Select
NewWinProc = CallWindowProc(OldWinProc, hwnd, Msg, wParam, lParam)
End Function

发表于: 2004-07-27 at 22:54 | IP已记录

然后新建一个菜单类（CMenu）：

Option Explicit
Option Base 1
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Type TMenuItem '自定义结构
        ItemID As Long '菜单ID
        ItemText As String '菜单名称
        SubMenu As Long '菜单的类型
        AttachMenu As Long '所依附的自菜单ID
        DrawSubMenuItem As Boolean '重新绘制子菜单项
        ItemCount As Integer '菜单条目总数
End Type
Private Type MENUITEMINFO '菜单结构
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type
Private Const HS_CROSS = 4                   '  +++++
Private Const BS_HATCHED = 2
Private Const DI_MASK = &H1
Private Const DI_IMAGE = &H2
Private Const DI_NORMAL = &H3
Private Const DI_DEFAULTSIZE = &H8
Private Const TRANSPARENT = 1
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_CHECKMARKS = &H8
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Const MIIM_STRING = &H40
Private Const MIIM_BITMAP = &H80
Private Const MIIM_FTYPE = &H100
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const ODT_MENU = 1
Private Const TPM_RIGHTBUTTON = &H2&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_STRING = &H0&
Private Const MF_OWNERDRAW = &H100& '标志为自绘类型
Private Const MFT_OWNERDRAW = &H100& '同上
Private Const ODS_CHECKED = &H8 '菜单状态
Private Const ODS_FOCUS = &H10 '同上
Private Const ODS_SELECTED = &H1 '同上
Private Const IsSubMenu = 1 '自定义常数：为菜单项标志为子菜单
Private Const IsSubMenuItem = 2 '自定义常数：所依附的子菜单的ID
Private LB As LOGBRUSH
Private MyRect As RECT
Private hMenu As Long
Private MenuItemCount As Long
Private MenuItem(8) As TMenuItem
Private IconhInst(8) As Long
Private MenuItemEx As MENUITEMINFO
Private Text(8) As String
Private hBrush As Long
Public Sub CMenu_Initialize() '初始化
Dim I As Integer
'设置菜单项的名称
MenuItem(1).ItemCount = 8
MenuItem(1).ItemText = "显示桌面"
MenuItem(2).ItemText = "运行游戏"
MenuItem(3).ItemText = "浏览教程"
MenuItem(4).ItemText = "任意程序"
MenuItem(5).ItemText = "打开"
MenuItem(6).ItemText = "聆听音乐"
MenuItem(7).ItemText = "弹出CD"
MenuItem(8).ItemText = "调教闹钟"
'为子菜单和子菜单项添上标记
MenuItem(3).SubMenu = IsSubMenu
MenuItem(4).SubMenu = IsSubMenu
MenuItem(5).SubMenu = IsSubMenuItem
MenuItem(5).AttachMenu = 4
MenuItem(5).DrawSubMenuItem = True
MenuItem(6).SubMenu = IsSubMenuItem
MenuItem(6).AttachMenu = 3
MenuItem(6).DrawSubMenuItem = True
'为所有菜单项加上ID
  For I = 1 To MenuItem(1).ItemCount
    MenuItem(I).ItemID = I
  Next
IconhInst(1) = LoadImage(App.hInstance, App.Path & "\" & "1.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(2) = LoadImage(App.hInstance, App.Path & "\" & "2.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(3) = LoadImage(App.hInstance, App.Path & "\" & "3.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(4) = LoadImage(App.hInstance, App.Path & "\" & "4.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(5) = LoadImage(App.hInstance, App.Path & "\" & "8.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(6) = LoadImage(App.hInstance, App.Path & "\" & "5.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(7) = LoadImage(App.hInstance, App.Path & "\" & "6.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
IconhInst(8) = LoadImage(App.hInstance, App.Path & "\" & "7.ico", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
End Sub
Public Sub CreatePopMenu() '创造空的自绘弹出式菜单
hMenu = CreatePopupMenu()
End Sub
Public Sub OnAppendPopMenu() '为菜单添加条目
Dim I As Long
Dim C As Long
Dim Skip As Long
  For I = 1 To 8
    Select Case MenuItem(I).SubMenu
    Case IsSubMenu
      SetMenu hMenu, MenuItem(I).ItemText, MenuItem(I).ItemID
    Case IsSubMenuItem
    Case 0
        AppendMenu hMenu, MF_STRING Or MF_BYCOMMAND Or MF_OWNERDRAW, I, MenuItem(I).ItemText
    End Select
  Next
End Sub
Public Sub SetMenu(hMenu As Long, Text As String, MenuIndex As Long) '设置为二级或更高的菜单
Dim MenuItemEx As MENUITEMINFO
Dim hMenu2 As Long
hMenu2 = CreatePopupMenu() '创造新的空的自绘弹出式菜单
  With MenuItemEx
    .cbSize = Len(MenuItemEx)
    .cch = Len(Text) * 2
    .dwItemData = False
    .dwTypeData = Text
    .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_ID Or MIIM_DATA
    .fType = MFT_OWNERDRAW
    .wID = MenuIndex
    .hSubMenu = hMenu2
    End With
    InsertMenuItem hMenu, MenuIndex, False, MenuItemEx
      Dim I As Integer
        For I = 1 To MenuItem(1).ItemCount
          If MenuItem(I).AttachMenu = MenuIndex Then
            AppendMenu hMenu2, MF_STRING Or MF_BYCOMMAND Or MF_OWNERDRAW, MenuItem(I).ItemID, MenuItem(I).ItemText
          End If
        Next
End Sub
Public Sub TrackMenu(x As Long, y As Long) '弹出菜单
TrackPopupMenu hMenu, TPM_RIGHTBUTTON, x, y, 0, Form1.hwnd, MyRect
End Sub
Public Sub OnMeasureItem(lParam As Long)  '设置菜单的大小
On Error GoTo MyExitSub
Dim lpMIS As MEASUREITEMSTRUCT
Dim I As Long
  CopyMemory lpMIS, ByVal lParam, Len(lpMIS)
    If MenuItem(lpMIS.ItemID).DrawSubMenuItem = True Then
      lpMIS.itemHeight = 20
      lpMIS.itemWidth = 80
    Else
      lpMIS.itemHeight = 26
      lpMIS.itemWidth = 118
    End If
 CopyMemory ByVal lParam, lpMIS, Len(lpMIS)
   Exit Sub
MyExitSub:
  Exit Sub
:
End Sub
Public Sub OnDrawItem(lParam As Long)  '为菜单绘制样貌
Dim lpDIS As DRAWITEMSTRUCT
CopyMemory lpDIS, ByVal lParam, Len(lpDIS)
  Dim DC As Long
  Dim Mem As Long
  Dim Obj As Long
  Dim BitmaphInst As Long
  Dim Color As Long
  Dim MenuRect As RECT
  Dim MenuRect2 As RECT
  Dim TextLen As Long
  Dim hBrush As Long
   If lpDIS.CtlType = ODT_MENU Then
     If MenuItem(lpDIS.ItemID).DrawSubMenuItem = False Then
       MenuRect = lpDIS.rcItem
       MenuRect.Left = 20
       Color = RGB(255, 149, 149)
       LB.lbColor = Color
       hBrush = CreateBrushIndirect(LB)
       FillRect lpDIS.hdc, MenuRect, hBrush
       Mem = CreateCompatibleDC(lpDIS.hdc)
       BitmaphInst = LoadImage(App.hInstance, App.Path & "\" & "1.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) '读取菜单左边图案
       Obj = SelectObject(Mem, BitmaphInst)
       MenuRect = lpDIS.rcItem
       SetBkMode lpDIS.hdc, TRANSPARENT '让背景色为透明色
       BitBlt lpDIS.hdc, 0, 0, 20, MenuRect.Left + MenuRect.Bottom, Mem, 0, 0, SRCCOPY
       MenuRect.Top = lpDIS.rcItem.Top + 6
       DrawText lpDIS.hdc, MenuItem(lpDIS.ItemID).ItemText, Len(MenuItem(lpDIS.ItemID).ItemText) * 2, MenuRect, DT_CENTER Or DT_SINGLELINE
       DrawIconEx lpDIS.hdc, 20, lpDIS.rcItem.Top, IconhInst(lpDIS.ItemID), 20, 20, 0, 0, DI_NORMAL
         If lpDIS.itemState And ODS_SELECTED Then '当菜单项被选中时重绘菜单项
           MenuRect2 = lpDIS.rcItem
           MenuRect2.Left = 20
           MenuRect2.Bottom = MenuRect2.Bottom
           DrawEdge lpDIS.hdc, MenuRect2, BDR_SUNKENOUTER, BF_RECT '选中时有凹进去的效果
           MenuRect2.Top = lpDIS.rcItem.Top + 6
           MenuRect2.Left = lpDIS.rcItem.Left
           DrawText lpDIS.hdc, MenuItem(lpDIS.ItemID).ItemText, Len(MenuItem(lpDIS.ItemID).ItemText) * 2, MenuRect2, DT_CENTER Or DT_SINGLELINE Or DT_RIGHT
         End If
       Else
           DrawText lpDIS.hdc, MenuItem(lpDIS.ItemID).ItemText, Len(MenuItem(lpDIS.ItemID).ItemText) * 2, lpDIS.rcItem, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
           DrawIconEx lpDIS.hdc, 0, lpDIS.rcItem.Top, IconhInst(lpDIS.ItemID), 20, 20, 0, 0, DI_NORMAL
     End If
   End If
DeleteObject BitmaphInst
End Sub

发表于: 2004-07-27 at 22:55 | IP已记录

最后就是在窗口代码里面的：

Option Explicit
Private Sub Form_Load()
CallWinProc
Menu.CMenu_Initialize
Menu.CreatePopMenu
Menu.OnAppendPopMenu
List.OnCreate Me.hwnd
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
  GetCursorPos MyPoint
  Menu.TrackMenu MyPoint.x, MyPoint.y
End If
End Sub