好文共分享 (转载 homezj )

转载一位 homezj 大虾的制作的 ToolBar 工具栏控件但是不明白怎么封装，怎么用这个类？具体一点谢谢原文如下：  （一）  
MS的ToolBar是是最容易找到找的工具栏控件了，简单方便实用，但它的缺点也是明显的，样式古板，与这个时代有点不合拍。为解决这个问题，我专门写了一个类。
    其实ToolBar提供了一个CustomDraw功能，MS为你已搭好了ToolBar的框架，只是ToolBar的模样交给你自己绘，很简单地，就可以用任意你想要的模样，使用ToolBar的所有功能，这比自己做ToolBar是不是更容易更方便？
    该功能当然是通过消息机制触发，其核心就是通过WM_NOTIFY消息，这个消息的lParam参数，就是指向一个NMHDR结构的地址，通过NMHDR 结构，我们可得知产生消息的hwnd等信息，确定控件类型，并进一步决定整个结构的类型是什么，进而获得NMCUSTOMDRAW和 NMTBCUSTOMDRAW结构，NMTBCUSTOMDRAW最前面就是NMCUSTOMDRAW，而NMCUSTOMDRAW最前面就是 NMHDR，所以一个NMHDR、NMCUSTOMDRAW，NMCUSTOMDRAW实际上都是同一个地址lParam，只是需根据前面信息，最终确定整个结构的长度而已。    WM_LBUTTONDOWN、WM_LBUTTONUP消息本应与本类无关，只是ToolBar中带菜单的样式的按钮，我一时不知如何获取其Drap消息，所以被迫采用了判断鼠标动作的权宜之计，不知哪位能把这个改改。    DrawToolbarButton过程是改变按钮样式的核心内容，在这部分下下功夫，就可以做出自己理想的ToolBar了'测试窗体中的代码：需有个ToolBar，最好有ImageList。
Option Explicit
Private Sub Command1_Click()
Dim i As Long
    With oTbr
        Randomize
        'If .BackPicture = "" Then
        '    .BackPicture = "e:\12.jpg"
        'Else
        '    .BackPicture = ""
        'End If
        .BorderColor = vbBlue  '只有BorderStyle大于3时才有效
        .BackColor = Rnd * (2 ^ 24)
        .TextColor = Rnd * (2 ^ 24)
        .TextHiColor = Rnd * (2 ^ 24)
        i = .BorderStyle + 1
        If i > 4 Then i = 0
        .BorderStyle = i   '取值范围0-4
    End With
End Sub
Private Sub Command2_Click()
    If oTbr Is Nothing Then
        Set oTbr = New cToolbar
        With oTbr
        .BindToolBar Toolbar1.hWnd
        End With
        Command2.Caption = "取消样式"
        Command1.Enabled = True
    Else
        Set oTbr = Nothing
        Toolbar1.Refresh
        Command2.Caption = "加载样式"
        Command1.Enabled = False
    End If
End Sub
Private Sub Form_Load()
    Command1.Caption = "随机变样"
    Command2.Caption = "加载样式"
    Command2.Enabled = True
    Command1.Enabled = False
End SubPrivate Sub Form_Unload(Cancel As Integer)
    Set oTbr = Nothing
End Sub
--------------------------------------------------
--------------------------------------------------
'标准模块中的代码：
Option Explicit
Public oTbr As cToolbar
Public OldWindowProc As Long
Private Const WM_NOTIFY As Long = &H4E
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private 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 Function TBSubClass(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
    Dim ProcOK As Long
    Static MouseDown As Boolean
    If Msg = WM_NOTIFY Then
        ProcOK = oTbr.MsgProc(lp, MouseDown)
    ElseIf Msg = WM_LBUTTONDOWN Then
        MouseDown = True
    ElseIf Msg = WM_LBUTTONUP Then
        MouseDown = False
    End If
    If ProcOK Then
        TBSubClass = ProcOK
    Else
        TBSubClass = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp)
    End If
End Function

解决方案 »

  1.   

    （二）进入正题了，下面就该是类中的代码了，因为主要是利用API，所以声明很多，耐心点吧！'类模块中的代码:类名cToolbar
    Option Explicit
    Private Const CDDS_ITEM As Long = &H10000
    Private Const CDDS_PREPAINT As Long = &H1
    Private Const CDDS_ITEMPREPAINT As Long = (CDDS_ITEM Or CDDS_PREPAINT)
    Private Const CDRF_SKIPDEFAULT As Long = &H4
    Private Const CDRF_NOTIFYITEMDRAW As Long = &H20
    Private Const CDIS_CHECKED As Long = &H8
    Private Const CDIS_DISABLED As Long = &H4
    Private Const CDIS_HOT As Long = &H40
    Private Const CDIS_SELECTED As Long = &H1
    Private Const GWL_WNDPROC = (-4)
    Private Const WM_USER As Long = &H400
    Private Const TB_GETBUTTONTEXTA As Long = (WM_USER + 45)
    Private Const TB_GETIMAGELIST As Long = (WM_USER + 49)
    Private Const TB_GETHOTIMAGELIST = (WM_USER + 53)
    Private Const TB_GETDISABLEDIMAGELIST = (WM_USER + 55)
    Private Const TB_GETBITMAP As Long = (WM_USER + 44)
    Private Const TB_COMMANDTOINDEX As Long = (WM_USER + 25)
    Private Const TB_GETBUTTON As Long = (WM_USER + 23)
    Private Const TBSTYLE_LIST As Long = &H1000
    Private Const TBSTYLE_SEP As Long = &H1
    Private Const TBSTYLE_DROPDOWN As Long = &H8
    Private Const ILD_NORMAL As Long = &H0
    Private Const DST_TEXT = &H1&
    Private Const DST_ICON As Long = &H3
    Private Const DSS_DISABLED = &H20&
    Private Const CLR_NONE As Long = &HFFFFFFFF
    Private Const GWL_STYLE As Long = -16
    Private Const PS_SOLID As Long = 0
    Private Const TA_LEFT = 0
    Private Const TA_RIGHT = 2
    Private Const TA_CENTER = 6
    Private Const BF_FLAT = &H4000
    Private Const BF_BOTTOM = &H8
    Private Const BF_LEFT = &H1
    Private Const BF_RIGHT = &H4
    Private Const BF_TOP = &H2
    Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
    Private Const BDR_RAISEDOUTER = &H1
    Private Const BDR_RAISEDINNER = &H4
    Private Const BDR_SUNKENINNER = &H8
    Private Const BDR_SUNKENOUTER = &H2
    Private Const BDR_OUTER = &H3
    Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
    Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
    Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
    Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
    End Type
    Private Type ICONINFO
        fIcon As Long
        xHotspot As Long
        yHotspot As Long
        hbmMask As Long
        hbmColor As Long
    End Type
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    Private Type POINTL
        X As Long
        Y As Long
    End Type
    Private Type Size
        cx As Long
        cy As Long
    End Type
    Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 32
    End Type
    Private Type TBBUTTON
        iBitmap As Long
        idCommand As Long
        fsState As Byte
        fsStyle As Byte
        bReserved(1) As Byte
        dwData As Long
        iString As Long
    End Type
    Private Type MemHdc
        hdc As Long
        Bmp As Long
        obm As Long
    End Type
    Private Type NMHDR
        hwndFrom As Long
        idfrom As Long
        code As Long
    End Type
    Private Type NMCUSTOMDRAW
        hdr As NMHDR
        dwDrawStage As Long
        hdc As Long
        rc As RECT
        dwItemSpec As Long
        uItemState As Long
        lItemlParam As Long
    End Type
    Private Type NMTBCUSTOMDRAW
       nmcd As NMCUSTOMDRAW
       hbrMonoDither As Long
       hbrLines As Long
       hpenLines As Long
       clrText As Long
       clrMark As Long
       clrTextHighlight As Long
       clrBtnFace As Long
       clrBtnHighlight As Long
       clrHighlightHotTrack As Long
       rcText As RECT
       nStringBkMode As Long
       nHLStringBkMode As Long
    End Type
    Private m_hWnd As Long
    Private m_lngBackColor As Long
    Private m_lngBrdStyle As Long
    Private m_lngTextColor As Long
    Private m_lngTextHiColor As Long
    Private m_strBkPicture As String
    Private m_lngBrdColor As LongPrivate mpicBk As StdPicture
    Private mlngImgList As Long
    Private mdcWhite As MemHdc
    Private mlngHotImgList As Long
    Private mlngDsbImgList As Long
    Private mlngBtnHiAlpha As Long
    Private mlngBtnDownAlpha As Long
    Private mlngIconWidth As Long
    Private mlngIconHeight As Long
    Private Font As LOGFONT
    '消息与管理类
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function ShowWindow Lib "user32" Alias "ShowWindowAsync" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    'GDI对象类
    Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
    Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
    Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    '区域、绘图、文本类
    Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function SetRect Lib "user32.dll" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTL, ByVal nCount As Long) As Long
    Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
    Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function DrawState Lib "user32.dll" Alias "DrawStateA" (ByVal hdc As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal hIco As Long, ByVal wParam As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal hHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal blendFunction As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    'ImageList类
    Private Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal X As Long, ByVal Y As Long, ByVal fStyle As Long) As Long
    Private Declare Function ImageList_GetBkColor Lib "comctl32.dll" (ByVal himl As Long) As Long
    Private Declare Function ImageList_SetBkColor Lib "comctl32.dll" (ByVal himl As Long, ByVal clrBk As Long) As Long
    Private Declare Function ImageList_GetIcon Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal flags As Long) As Long
      

  2.   

    （三）
    '类中的各种属性与方法，主要用于外部调用
    Friend Property Let BorderColor(ByVal vData As Long)
        If m_lngBrdColor <> vData Then
            m_lngBrdColor = vData
            If m_lngBrdStyle > 3 Then Refresh
        End If
    End Property
    Friend Property Get BorderColor() As Long
        BorderColor = m_lngBrdColor
    End Property
    Friend Property Let BackPicture(ByVal vData As String)
        If vData <> "" And Dir(vData) <> "" Then
            If LCase(m_strBkPicture) <> LCase(vData) Then
                m_strBkPicture = vData
                Set mpicBk = LoadPicture(m_strBkPicture)
                Refresh
            End If
        Else
            Set mpicBk = Nothing
            m_strBkPicture = ""
        End If
    End Property
    Friend Property Get BackPicture() As String
        BackPicture = m_strBkPicture
    End Property
    Friend Property Let FontName(ByVal vData As String)
        Dim s As String, i As Long
        vData = Trim(vData)
        s = StrConv(Font.lfFaceName, vbUnicode)
        i = InStr(1, s, Chr(0))
        If i > 0 Then
            s = Left$(s, i - 1)
        End If
        If s <> vData Then
            CopyMemory Font.lfFaceName(0), ByVal vData, lstrlen(vData)
            Refresh
        End If
    End Property
    Friend Property Get FontName() As String
        Dim s As String, i As Long
        s = StrConv(Font.lfFaceName, vbUnicode)
        i = InStr(1, s, Chr(0) - 1)
        If i > 0 Then
            FontName = Left$(s, i - 1)
        Else
            FontName = s
        End If
    End PropertyFriend Property Let FontUnderline(ByVal vData As Boolean)
        Dim i As Long
        i = IIf(vData, 1, 0)
        If Font.lfUnderline <> i Then
            Font.lfUnderline = i
            Refresh
        End If
    End Property
    Friend Property Get FontUnderline() As Boolean
        FontUnderline = (Font.lfUnderline = 1)
    End Property
    Friend Property Let FontItalic(ByVal vData As Boolean)
        Dim i As Long
        i = IIf(vData, 1, 0)
        If Font.lfItalic <> i Then
            Font.lfItalic = i
            Refresh
        End If
    End Property
    Friend Property Get FontItalic() As Boolean
        FontItalic = (Font.lfItalic = 1)
    End Property
    Friend Property Let FontBold(ByVal vData As Boolean)
        Dim i As Long
        i = IIf(vData, 700, 400)
        If Font.lfWeight <> i Then
            Font.lfWeight = i
            Refresh
        End If
    End Property
    Friend Property Get FontBold() As Boolean
        FontBold = (Font.lfWeight = 700)
    End Property
    Friend Property Let FontSize(ByVal vData As Long)
        If Font.lfHeight <> vData And vData >= 7 And vData <= 16 Then
            Font.lfHeight = vData
            Font.lfWidth = 0
            Refresh
        End If
    End Property
    Friend Property Get FontSize() As Long
        FontSize = Font.lfHeight
    End Property
    Friend Property Let BorderStyle(ByVal vData As Long)
        If m_lngBrdStyle <> vData Then
            m_lngBrdStyle = vData
            Refresh
        End If
    End Property
    Friend Property Get BorderStyle() As Long
        BorderStyle = m_lngBrdStyle
    End Property
    Friend Property Let TextHiColor(ByVal vData As Long)
        m_lngTextHiColor = vData
    End Property
    Friend Property Get TextHiColor() As Long
        TextHiColor = m_lngTextHiColor
    End Property
    Friend Property Let TextColor(ByVal vData As Long)
        If m_lngTextColor <> vData Then
            m_lngTextColor = vData
            Refresh
        End If
    End Property
    Friend Property Get TextColor() As Long
        TextColor = m_lngTextColor
    End Property
    Friend Property Let BackColor(ByVal vData As Long)
        If m_lngBackColor <> vData Then
            m_lngBackColor = vData
            If mpicBk Is Nothing Then Refresh
        End If
    End Property
    Friend Property Get BackColor() As Long
        BackColor = m_lngBackColor
    End Property
    Friend Sub BindToolBar(ByVal hWnd As Long)
        If m_hWnd = 0 Then
            m_hWnd = hWnd
            If m_hWnd Then
              OldWindowProc = GetWindowLong(m_hWnd, GWL_WNDPROC)
              SetWindowLong m_hWnd, GWL_WNDPROC, AddressOf TBSubClass
            End If
            Refresh
        End If
    End Sub
    Private Sub Class_Initialize()
        Dim rc As RECT, hBrush As Long, i As Long
        m_lngTextColor = vbBlack
        m_lngTextHiColor = vbRed
        m_lngBackColor = &HD7E9EB
        m_lngBrdColor = &H0
        mlngBtnHiAlpha = 96
        mlngBtnDownAlpha = 192
        rc.Bottom = 128
        rc.Right = 128
        i = GetDC(0)
        mdcWhite = NewMyHdc(i, rc.Right, rc.Bottom)
        ReleaseDC 0, i
        hBrush = CreateSolidBrush(vbWhite)
        FillRect mdcWhite.hdc, rc, hBrush
        DeleteObject hBrush
        With Font
            .lfCharSet = 1
            .lfHeight = 12
            .lfWeight = 400
        End With
    End Sub
    Private Sub Class_Terminate()
        SetWindowLong m_hWnd, GWL_WNDPROC, OldWindowProc
        mdcWhite = DelMyHdc(mdcWhite)
        Set mpicBk = Nothing
    End Sub
    Friend Sub Refresh()
    Dim rc As RECT
        If m_hWnd <> 0 Then
            ShowWindow m_hWnd, 0
            ShowWindow m_hWnd, 5
        End If
    End Sub
      

  3.   

    （四）
    '几个GDI绘图函数功能的封装，有一定通用性，有些是我平时自己就喜欢用的模块。Private Function NewMyHdc(dHdc As Long, w As Long, h As Long, Optional Bm As Long) As MemHdc
        With NewMyHdc
            .hdc = CreateCompatibleDC(dHdc)
            If Bm = 0 Then
                .Bmp = CreateCompatibleBitmap(dHdc, w, h)
            Else
                .Bmp = Bm
            End If
            .obm = SelectObject(.hdc, .Bmp)
        End With
    End Function
    Private Function DelMyHdc(MyHdc As MemHdc, Optional nobmp As Boolean) As MemHdc
        With MyHdc
            If .hdc <> 0 Then
                SelectObject .hdc, .obm
                If nobmp = False Then DeleteObject .Bmp
                DeleteDC .hdc
            End If
        End With
    End Function
    Private Sub DrawPloy3(hdc As Long, rcDrop As RECT, Up As Boolean)
        '画下拉菜单的小三角形
        Dim ploy(2) As POINTL
        Dim hBrush As Long, hOldBrush As Long
        Dim hPen As Long, hOldPen As Long
        With rcDrop
            If Up Then
                .Left = .Left - 1
                .Right = .Right - 1
                .Top = .Top - 1
                .Bottom = .Bottom - 1
                hBrush = CreateSolidBrush(m_lngTextHiColor)
                hPen = CreatePen(PS_SOLID, 1, m_lngTextHiColor)
            Else
                hBrush = CreateSolidBrush(m_lngTextColor)
                hPen = CreatePen(PS_SOLID, 1, m_lngTextColor)
            End If
            hOldPen = SelectObject(hdc, hPen)
            hOldBrush = SelectObject(hdc, hBrush)
            ploy(0).X = (.Left + .Right - 5) \ 2
            ploy(0).Y = (.Top + .Bottom) \ 2
            ploy(1).X = ploy(0).X + 4
            ploy(1).Y = ploy(0).Y
            ploy(2).X = ploy(0).X + 2
            ploy(2).Y = ploy(0).Y + 2
        End With
        Polygon hdc, ploy(0), 3
        SelectObject hdc, hOldPen
        SelectObject hdc, hOldBrush
        DeleteObject hPen
        DeleteObject hBrush
    End Sub
    Private Sub GetIconSize(hIcon As Long)
        '取得图像列表框图标的大小
        Dim Bm As BITMAP, bi As ICONINFO
        GetIconInfo hIcon, bi
        GetObj bi.hbmColor, Len(Bm), Bm
        DeleteObject bi.hbmColor
        DeleteObject bi.hbmMask
        mlngIconWidth = Bm.bmWidth
        mlngIconHeight = Bm.bmHeight
    End Sub
    Private Sub DrawRect(hdc As Long, rc As RECT, State As Long, Optional IsDrop As Boolean)
        Dim hPen As Long
        If (State > 0 Or IsDrop) And m_lngBrdStyle > 3 Then
            hPen = CreatePen(PS_SOLID, 1, m_lngBrdColor)
            If IsDrop Then rc.Left = rc.Left - 1
            FrameRect hdc, rc, hPen
            If IsDrop Then rc.Left = rc.Left + 1
            DeleteObject hPen
            Exit Sub
        End If
        Select Case State
            Case 0  '普通状态
                Select Case m_lngBrdStyle
                    Case 1
                        If IsDrop Then DrawEdge hdc, rc, BDR_OUTER, BF_RECT Or BF_FLAT
                    Case 2
                        DrawEdge hdc, rc, BDR_RAISEDOUTER, BF_RECT
                    Case 3
                        DrawEdge hdc, rc, EDGE_RAISED, BF_RECT
                End Select
            Case 1  '高亮状态
                Select Case m_lngBrdStyle
                    Case 0
                        DrawEdge hdc, rc, BDR_RAISEDINNER, BF_RECT
                    Case 1, 2, 3
                        DrawEdge hdc, rc, EDGE_RAISED, BF_RECT
                End Select
            Case 2  '按下状态
                Select Case m_lngBrdStyle
                    Case 0
                        DrawEdge hdc, rc, BDR_SUNKENOUTER, BF_RECT
                    Case 1
                        DrawEdge hdc, rc, BDR_SUNKENINNER, BF_RECT
                    Case 2, 3
                        DrawEdge hdc, rc, EDGE_SUNKEN, BF_RECT
                End Select
        End Select
    End Sub
      

  4.   

    （五）
    '最后一部分，也是最核心的消息处理代码与主绘图过程Friend Function MsgProc(lParam As Long, MouseDown As Boolean) As Long
        Dim tHDR As NMHDR
        Dim className As String * 32
        Dim retval As Long
        CopyMemory tHDR, ByVal lParam, Len(tHDR)
        If tHDR.hwndFrom <> 0 Then
            retval = GetClassName(tHDR.hwndFrom, className, 33)
            If retval > 0 Then
                If Left$(className, retval) = "msvb_lib_toolbar" Then
                    MsgProc = OnCustomDraw(lParam, MouseDown)
                End If
            End If
        End If
    End Function
    Private Function OnCustomDraw(lParam As Long, MouseDown As Boolean) As Long
        Dim tTBCD As NMTBCUSTOMDRAW
        Dim hBrush As Long
        CopyMemory tTBCD, ByVal lParam, Len(tTBCD)
        With tTBCD.nmcd
            Select Case .dwDrawStage
                Case CDDS_ITEMPREPAINT
                    OnCustomDraw = CDRF_SKIPDEFAULT
                    DrawToolbarButton .hdr.hwndFrom, .hdc, .dwItemSpec, .uItemState, .rc, MouseDown
                Case CDDS_PREPAINT
                    OnCustomDraw = CDRF_NOTIFYITEMDRAW
                    GetClientRect .hdr.hwndFrom, .rc
                    If mpicBk Is Nothing Then
                        hBrush = CreateSolidBrush(m_lngBackColor)
                    Else
                        hBrush = CreatePatternBrush(mpicBk)
                    End If
                    FillRect .hdc, .rc, hBrush
                    DeleteObject hBrush
            End Select
        End With
    End Function
    Private Sub DrawToolbarButton(ByVal hWnd As Long, ByVal hdc As Long, itemSpec As Long, ByVal itemState As Long, tR As RECT, MouseDown As Boolean)
        Dim i As Long
        Dim bPushed As Boolean, bDropDown As Boolean, bHover As Boolean
        Dim bDisabled As Boolean, bChecked As Boolean
        Dim bSkipped As Boolean, bBottomText As Boolean, bNoDsbIcon As Boolean
        Dim hIcon As Long, hImageList As Long
        Dim tTB As TBBUTTON
        Dim szText As Size, rcDrop As RECT, rcIcon As RECT
        Dim hOldPen As Long, hPen As Long
        Dim hFont As Long, hOldFont As Long
        Dim sCaption As String, bFirstSetBk As Boolean
        Dim lDropWidth As Long, lTxtColor As Long
        sCaption = String$(128, vbNullChar)
        i = SendMessage(hWnd, TB_GETBUTTONTEXTA, itemSpec, ByVal sCaption)
        If i > 0 Then
            sCaption = Left$(sCaption, i)
        Else
            sCaption = ""
        End If
        i = GetWindowLong(hWnd, GWL_STYLE)
        bBottomText = ((i And TBSTYLE_LIST) = 0)
        i = SendMessage(hWnd, TB_COMMANDTOINDEX, itemSpec, ByVal 0)
        SendMessage hWnd, TB_GETBUTTON, i, tTB
       
        bDisabled = (itemState And CDIS_DISABLED)
        bChecked = (itemState And CDIS_CHECKED)
        bHover = (itemState And CDIS_HOT)
        bPushed = (itemState And CDIS_SELECTED)
       
        If tTB.fsStyle And TBSTYLE_SEP Then '分隔线按钮
            hPen = CreatePen(PS_SOLID, 1, vb3DShadow)
            hOldPen = SelectObject(hdc, hPen)
            MoveToEx hdc, tR.Left + 2&, tR.Top + 1&, ByVal 0
            LineTo hdc, tR.Left + 2&, tR.Bottom - 1&
            SelectObject hdc, hOldPen
            DeleteObject hPen
            Exit Sub
        Else
            hImageList = SendMessage(hWnd, TB_GETIMAGELIST, 0, ByVal 0)
            If hImageList <> 0 Then '取得主图像列表
                If mlngImgList <> hImageList Then
                    mlngImgList = hImageList
                    bFirstSetBk = True
                    mlngIconWidth = 0
                End If
                If bDisabled Then   '取得禁用图像列表
                    i = SendMessage(hWnd, TB_GETDISABLEDIMAGELIST, 0, ByVal 0)
                    If i <> 0 And i <> hImageList Then
                        hImageList = i
                        If mlngDsbImgList <> i Then
                            mlngDsbImgList = i
                            bFirstSetBk = True
                        End If
                    Else
                        bNoDsbIcon = True
                    End If
                ElseIf bHover Then  '取得热图像列表
                    i = SendMessage(hWnd, TB_GETHOTIMAGELIST, 0, ByVal 0)
                    If i <> 0 And i <> hImageList Then
                        hImageList = i
                        If mlngHotImgList <> i Then
                            mlngHotImgList = i
                            bFirstSetBk = True
                        End If
                    End If
                End If
                If bFirstSetBk Then '首次使用需设定背景色
                    If ImageList_GetBkColor(hImageList) <> -1 Then
                        ImageList_SetBkColor hImageList, CLR_NONE
                    End If
                End If
                hIcon = ImageList_GetIcon(hImageList, tTB.iBitmap, ILD_NORMAL)
                If mlngIconWidth = 0 Then GetIconSize hIcon
            End If
            '根据状态创建不同刷子与画笔
            lTxtColor = m_lngTextColor
            If bChecked Or bPushed Then
                AlphaBlend hdc, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, mdcWhite.hdc, 0, 0, tR.Right - tR.Left, tR.Bottom - tR.Top, mlngBtnDownAlpha * &H10000
            ElseIf bHover Then
                AlphaBlend hdc, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, mdcWhite.hdc, 0, 0, tR.Right - tR.Left, tR.Bottom - tR.Top, mlngBtnHiAlpha * &H10000
                lTxtColor = m_lngTextHiColor
            Else
                bSkipped = True
            End If
            SetTextColor hdc, lTxtColor
            If tTB.fsStyle And TBSTYLE_DROPDOWN Then
                lDropWidth = 14
                bDropDown = bHover And MouseDown And Not bPushed
                SetRect rcDrop, tR.Right - lDropWidth, tR.Top, tR.Right, tR.Bottom
                tR.Right = tR.Right - lDropWidth
            End If
        End If
        SetBkMode hdc, 1    '文本背景透明
        If bSkipped = False Then    '根据样式不同，画不同边框并填充
            If bChecked Or bPushed Then
                DrawRect hdc, tR, 2
            Else
                DrawRect hdc, tR, 1
            End If
        Else
            DrawRect hdc, tR, 0
        End If
        If tTB.fsStyle And TBSTYLE_DROPDOWN Then    '处理下拉菜单的小按钮
            If bSkipped = False Or m_lngBrdStyle > 0 Then
                If bDropDown Then
                    AlphaBlend hdc, rcDrop.Left, rcDrop.Top, lDropWidth, rcDrop.Bottom - rcDrop.Top, mdcWhite.hdc, 0, 0, rcDrop.Right - rcDrop.Left, rcDrop.Bottom - rcDrop.Top, mlngBtnDownAlpha * &H10000
                End If
                If bDropDown Or bPushed Then
                    DrawRect hdc, rcDrop, 2, True
                ElseIf bHover Then
                    DrawRect hdc, rcDrop, 1, True
                Else
                    DrawRect hdc, rcDrop, 0, True
                    MouseDown = False
                End If
            Else
                MouseDown = False
            End If
            DrawPloy3 hdc, rcDrop, bHover And Not (bDropDown Or bPushed)
        End If
        '画图标与文本
        With rcIcon
            '计算图标区域
            .Top = tR.Top + 3
            If bBottomText = False Then .Left = tR.Left + 3
            If mlngIconWidth < 16 Then
                If bBottomText Then .Left = tR.Left + (tR.Right - tR.Left - 16) \ 2
                .Right = .Left + 16
            Else
                If bBottomText Then .Left = tR.Left + (tR.Right - tR.Left - mlngIconWidth) \ 2
                .Right = .Left + mlngIconWidth
            End If
            If mlngIconHeight < 16 Then
                .Bottom = .Top + 16
            Else
                .Bottom = .Top + mlngIconHeight
            End If
            If bHover And (Not (bPushed Or bChecked)) Then
                .Left = .Left - 1
                .Top = .Top - 1
                .Right = .Right - 1
                .Bottom = .Bottom - 1
            End If
            If hImageList <> 0 Then
                If bDisabled And bNoDsbIcon Then
                    If hIcon Then
                          DrawState hdc, 0, 0, hIcon, 0, .Left, .Top, 0, 0, DST_ICON Or DSS_DISABLED
                    End If
                Else
                    ImageList_Draw hImageList, tTB.iBitmap, hdc, .Left, .Top, ILD_NORMAL
                End If
            End If
            If Len(sCaption) > 0 Then
                hFont = CreateFontIndirect(Font)
                hOldFont = SelectObject(hdc, hFont)
                If bBottomText Then
                    If bDisabled Then
                        SetTextAlign hdc, TA_LEFT
                        GetTextExtentPoint32 hdc, sCaption, lstrlen(sCaption), szText
                        DrawState hdc, 0, 0, StrPtr(StrConv(sCaption, vbFromUnicode)), lstrlen(sCaption), (.Right + .Left - szText.cx) \ 2, .Bottom + 1, 0, 0, DST_TEXT Or DSS_DISABLED
                    Else
                        SetTextAlign hdc, TA_CENTER
                        TextOut hdc, (.Right + .Left) \ 2, .Bottom + 1, sCaption, lstrlen(sCaption)
                    End If
                Else
                    SetTextAlign hdc, TA_LEFT
                    If bDisabled Then
                        'GetTextExtentPoint32 hdc, sCaption, lstrlen(sCaption), szText
                        DrawState hdc, 0, 0, StrPtr(StrConv(sCaption, vbFromUnicode)), lstrlen(sCaption), .Right + 1, (.Top + .Bottom - Font.lfHeight) \ 2, 0, 0, DST_TEXT Or DSS_DISABLED
                    Else
                        TextOut hdc, .Right + 1, (.Top + .Bottom - Font.lfHeight) \ 2, sCaption, lstrlen(sCaption)
                    End If
                End If
                SelectObject hdc, hOldFont
                DeleteObject hFont
            End If
        End With
        If hIcon <> 0 Then DestroyIcon hIcon
    End Sub初涉Custom Draw消息处理，ToolBar本来我就很少用，所以我的兴趣是处理过程本身，而不是应用需求，很难静心深入研究它。
      

  5.   


    留言一
    如何获取其Drap消，可以这样改：
    Drap消息:TBN_DROPDOWN
    Private Const TBN_FIRST As Long = -700
    Private Const TBN_DROPDOWN As Long = (TBN_FIRST - 10)留言二
    你好，这个问题很严重啊，在2003下ImageList_GetIcon(hImageList, tTB.iBitmap, ILD_NORMAL)的返回是0啊，而且getlasterror还是为0
      

  6.   

    Codejock.Xtreme.Suite.Pro.ActiveX