modxpmenu.bas

VB下开发Windows XP风格的控件

Attribute VB_Name = "modXPMenu"
Option Explicit

Public Const XPMenuWndProp As String = "XPMenuWndProp"

Public CurMenuCount As Long
Private MenuItem() As CXPMenu
Private m_Style As Long '1-standard XP menu,2-gradient menu
Private m_LeftColor As Long
Private m_RightColor As Long


Public Sub RegisterMenu(ByVal hMenu As Long, ByVal wID As Long, ByVal hwndForm As Long, ByVal dep As Long, ByVal icon As Long)

  Dim i As Long

    For i = 0 To CurMenuCount - 1
        If Not (MenuItem(i) Is Nothing) Then
            If (MenuItem(i).m_hMain = hwndForm) And (MenuItem(i).MenuId = wID) Then
                Exit For '>---> Next
            End If
        End If
    Next i

    If i = CurMenuCount Then
        CurMenuCount = CurMenuCount + 1
        ReDim Preserve MenuItem(CurMenuCount - 1)
        Set MenuItem(CurMenuCount - 1) = New CXPMenu
        MenuItem(CurMenuCount - 1).m_hMain = hwndForm
        MenuItem(CurMenuCount - 1).InitMenu hMenu, wID, dep, m_Style, m_LeftColor, m_RightColor, icon
      Else 'NOT I...
        MenuItem(CurMenuCount - 1).InitMenu hMenu, wID, dep, m_Style, m_LeftColor, m_RightColor, icon
    End If

End Sub

Public Function XPMenuWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

  Dim m_FocusMenu As Long
  Dim szTmp As String
  Dim hMenuWnd As Long
  Dim m_Draw As DRAWITEMSTRUCT
  Dim m_MeasureItem As MEASUREITEMSTRUCT

    Select Case uMsg
      Case WM_DRAWITEM
        CopyMem m_Draw, ByVal lParam, Len(m_Draw)

        szTmp = Space(100) + Chr(0)
        GetClassName m_Draw.hwndItem, szTmp, 100
        '            If InStr(szTmp, "Thunder") = 0 Then
        For m_FocusMenu = 0 To CurMenuCount - 1
            If Not (MenuItem(m_FocusMenu) Is Nothing) Then
                If (MenuItem(m_FocusMenu).MenuId) = m_Draw.ItemId And MenuItem(m_FocusMenu).m_hMain = hWnd Then
                    MenuItem(m_FocusMenu).InitDraw m_Draw.hDC, m_Draw.ItemAction, m_Draw.ItemId, m_Draw.ItemState, _
                             m_Draw.rcItem.Left, m_Draw.rcItem.Top, m_Draw.rcItem.Bottom, m_Draw.rcItem.Right

                    hMenuWnd = WindowFromDC(m_Draw.hDC)

                    MenuItem(m_FocusMenu).DrawMenu

                    Exit For '>---> Next
                End If
            End If
        Next m_FocusMenu
        '                Exit Function
        '            End If
      Case WM_MEASUREITEM
        CopyMem m_MeasureItem, ByVal lParam, Len(m_MeasureItem)
        For m_FocusMenu = 0 To CurMenuCount - 1
            If Not (MenuItem(m_FocusMenu) Is Nothing) Then
                If (MenuItem(m_FocusMenu).MenuId = m_MeasureItem.ItemId) And MenuItem(m_FocusMenu).m_hMain = hWnd Then
                    MeasureMenu MenuItem(m_FocusMenu), m_MeasureItem
                    MenuItem(m_FocusMenu).DrawMenu
                    Exit For '>---> Next
                End If
            End If
        Next m_FocusMenu
        CopyMem ByVal lParam, m_MeasureItem, Len(m_MeasureItem)
        Exit Function '>---> Bottom
    End Select

    XPMenuWndProc = CallWindowProc(GetProp(hWnd, XPMenuWndProp), hWnd, uMsg, wParam, lParam)

End Function

Public Sub FreeXPMenu(frm As Form)

  Dim Index As Long

    For Index = 0 To CurMenuCount - 1
        If Not (MenuItem(Index) Is Nothing) Then
            If MenuItem(Index).m_hMain = frm.hWnd Then
                Set MenuItem(Index) = Nothing
            End If
        End If
    Next Index
    If GetProp(frm.hWnd, XPMenuWndProp) <> 0 Then
        SetWindowLong frm.hWnd, GWL_WNDPROC, GetProp(frm.hWnd, XPMenuWndProp)
        SetProp frm.hWnd, XPMenuWndProp, 0
    End If

End Sub

Public Sub EnumMenus(ByVal hMenu As Long, ByVal hWnd As Long, ByVal dep As Long, Optional ByVal bRefreshOnly As Boolean = False)

  Dim mii As MENUITEMINFO

  Dim lCount As Long
  Dim i As Long

  Dim szTmp     As String

    lCount = GetMenuItemCount(hMenu)

    For i = 0 To lCount - 1
        mii.cbSize = Len(mii)
        mii.fMask = MIIM_FTYPE Or MIIM_SUBMENU Or MIIM_ID
        GetMenuItemInfo hMenu, i, 1, mii

        szTmp = Space(256)
        GetMenuString hMenu, mii.wID, szTmp, 255, 0
        szTmp = Left(szTmp, InStr(szTmp, Chr(0)) - 1)

        mii.fType = mii.fType Or MF_OWNERDRAW
        If dep <> 0 And szTmp = "" Then
            mii.fType = mii.fType Or MF_SEPARATOR
        End If
        If dep = 0 And (szTmp = "=" Or Trim(szTmp) = "") Then
            mii.fType = mii.fType Or MF_SEPARATOR
        End If
        mii.cbSize = Len(mii)
        mii.fMask = MIIM_FTYPE
        SetMenuItemInfo hMenu, i, 1, mii

        If Not bRefreshOnly Then
            RegisterMenu hMenu, mii.wID, hWnd, dep, 0
        End If

        EnumMenus mii.hSubMenu, hWnd, dep + 1
    Next i

End Sub

Public Sub RefreshXPMenu(frm As Form, ByVal style As Long, ByVal leftcolor As Long, ByVal rightcolor As Long)

    m_Style = style
    m_LeftColor = leftcolor
    m_RightColor = rightcolor
    If GetProp(frm.hWnd, XPMenuWndProp) <> 0 Then
        EnumMenus GetMenu(frm.hWnd), frm.hWnd, 0, True
    End If

End Sub

Public Sub MakeXPMenu(frm As Form, ByVal style As Long, ByVal leftcolor As Long, ByVal rightcolor As Long)

    m_Style = style
    m_LeftColor = leftcolor
    m_RightColor = rightcolor
    If GetProp(frm.hWnd, XPMenuWndProp) = 0 Then
        EnumMenus GetMenu(frm.hWnd), frm.hWnd, 0
        SetProp frm.hWnd, XPMenuWndProp, SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf XPMenuWndProc)
    End If

End Sub

Private Sub MeasureMenu(ByRef Mnu As CXPMenu, ByRef MeasurePara As MEASUREITEMSTRUCT)

  Const MENU_HEIGHT As Long = 20
  Const ICON_WIDTH As Long = 20

  Dim m_drawDC As Long
  Dim m_size As Size
  Dim szTmp As String

    m_drawDC = GetDC(Mnu.m_hMain)
    szTmp = Mnu.Caption
    If InStr(Mnu.Caption, (vbTab)) <> 0 Then
        szTmp = szTmp + Space(2)
    End If
    GetTextExtentPoint32 m_drawDC, szTmp, lstrlen(szTmp), m_size

    If Mnu.Depth <> 0 Then

        If Mnu.Caption <> "" Then
            MeasurePara.itemWidth = ICON_WIDTH + m_size.cx + 6
            MeasurePara.itemHeight = MENU_HEIGHT
          Else 'NOT MNU.CAPTION...
            MeasurePara.itemWidth = ICON_WIDTH + m_size.cx + 6
            MeasurePara.itemHeight = 6
        End If
      Else 'NOT MNU.DEPTH...
        If Mnu.Caption <> "=" Then
            MeasurePara.itemWidth = m_size.cx + 2
            MeasurePara.itemHeight = MENU_HEIGHT
          Else 'NOT MNU.CAPTION...
            MeasurePara.itemWidth = 2
            MeasurePara.itemHeight = MENU_HEIGHT
        End If
    End If

    ReleaseDC Mnu.m_hMain, m_drawDC

End Sub

':) Ulli's VB Code Formatter V2.10.8 (2003-01-01 13:56:39) 6 + 190 = 196 Lines