cmenubar.cls

漂亮的VB版本的界面,界面可以进行扩展并且所需要的代码又非常的少。是一个优秀的原码你可以下载学习之用。

Private m_tR() As RECT
Private m_hSubMenu() As Long
Private m_iCount As Long
Private m_iDownOn As Long
Private m_iOver As Long

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR

Private m_oMenuBackgroundColor As OLE_COLOR

Private m_lCaptionHeight As Long

Private m_iRestore As Long
Private m_hMenuRestore() As Long
Private m_iMenuPosition() As Long
Private m_tMIIS() As MENUITEMINFO_STRINGDATA
Private m_sCaption() As String
Private m_sShortCut() As String
Private m_sAccelerator() As String
Private m_lMenuTextSize() As Long
Private m_lMenuShortCutSize() As Long

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_fnt As StdFont
Private m_fntSymbol As StdFont

Private m_lMenuItemHeight As Long

Private WithEvents m_cTmr As CTimer
Attribute m_cTmr.VB_VarHelpID = -1

Implements ISubclass
'===================================================
'
'===================================================
Friend Property Let Font( _
      fntThis As StdFont _
   )
   Set m_fnt = fntThis
End Property
'===================================================
'
'===================================================
Friend Property Set Font( _
      fntThis As StdFont _
   )
   Set m_fnt = fntThis
   m_fntSymbol.Name = "Marlett"
   m_fntSymbol.Size = m_fnt.Size * 1.2
End Property
'===================================================
'
'===================================================
Friend Property Get Font() As StdFont
   Set Font = m_fnt
End Property
'===================================================
'
'===================================================
Friend Sub SetColors( _
      ByVal oActiveMenuColor As OLE_COLOR, _
      ByVal oActiveMenuColorOver As OLE_COLOR, _
      ByVal oInActiveMenuColor As OLE_COLOR, _
      ByVal oMenuBackgroundColor As OLE_COLOR _
   )
   m_oActiveMenuColor = oActiveMenuColor
   m_oActiveMenuColorOver = oActiveMenuColorOver
   m_oInActiveMenuColor = oInActiveMenuColor
   m_oMenuBackgroundColor = oMenuBackgroundColor
End Sub
'===================================================
'
'===================================================
Private Property Get hFont() As Long
Dim iFn As IFont
   Set iFn = m_fnt
   hFont = iFn.hFont
End Property
'===================================================
'
'===================================================
Private Property Get hFontSymbol() As Long
Dim iFn As IFont
   Set iFn = m_fntSymbol
   hFontSymbol = iFn.hFont
End Property
'===================================================
'
'===================================================
Public Property Let hMenu(ByVal hTheMenu As Long)
   m_hMenu = hTheMenu
End Property
'===================================================
'
'===================================================
Public Property Get hMenu() As Long
   hMenu = m_hMenu
End Property
'===================================================
'
'===================================================
Public Sub Attach(ByVal lhWnd As Long)
   LockWindowUpdate lhWnd
   Detach
   m_hWnd = lhWnd
   Set m_cToolbarMenu = New cToolbarMenu
   m_cToolbarMenu.CoolMenuAttach m_hWnd, Me
   AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
   AttachMessage Me, m_hWnd, WM_MOUSEMOVE
   AttachMessage Me, m_hWnd, WM_DRAWITEM
   AttachMessage Me, m_hWnd, WM_MEASUREITEM
   AttachMessage Me, m_hWnd, WM_MENUCHAR
   LockWindowUpdate 0
End Sub
'===================================================
'
'===================================================
Public Sub Detach()
   If Not m_hWnd = 0 Then
      DetachMessage Me, m_hWnd, WM_LBUTTONDOWN
      DetachMessage Me, m_hWnd, WM_MOUSEMOVE
      DetachMessage Me, m_hWnd, WM_DRAWITEM
      DetachMessage Me, m_hWnd, WM_MEASUREITEM
      DetachMessage Me, m_hWnd, WM_MENUCHAR
   End If
   If Not m_cToolbarMenu Is Nothing Then
      m_cToolbarMenu.CoolMenuDetach
      Set m_cToolbarMenu = Nothing
   End If
End Sub
'===================================================
'
'===================================================
Public Property Let CaptionHeight(ByVal lHeight As Long)
   m_lCaptionHeight = lHeight
End Property
'===================================================
'
'===================================================
Public Sub Render( _
      ByVal hFnt As Long, _
      ByVal lhDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal lYoffset As Long _
   )
Dim iIdx As Long
Dim lC As Long
Dim lhDCC As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim sCap As String
Dim hFntOld As Long
Dim tTR As RECT, tBR As RECT
Dim lX As Long
Dim lR As Long
Dim bPress As Boolean
Dim lID As Long

   If Not (m_hMenu = 0) Then
      m_cMemDC.Width = lWidth
      m_cMemDC.Height = lHeight
      lhDCC = m_cMemDC.hdc

      hFntOld = SelectObject(lhDCC, hFnt)
      m_iCount = 0
      Erase m_tR

      lC = GetMenuItemCount(m_hMenu)
      If lC > 0 Then
         lX = 8
         lTop = lTop + 2
         BitBlt lhDCC, 0, 0, lWidth, lHeight, lhDC, lLeft, lTop, vbSrcCopy
         SetBkMode lhDCC, TRANSPARENT
         For iIdx = 0 To lC - 1
            lID = GetMenuItemID(m_hMenu, iIdx)
            If lID = -1 Then
               tMII.fMask = MIIM_TYPE
               tMII.cch = 127
               tMII.dwTypeData = String$(128, 0)
               tMII.cbSize = LenB(tMII)
               lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
               If (tMII.fType And MFT_STRING) = MFT_STRING Then
                  If tMII.cch > 0 Then
                     sCap = left$(tMII.dwTypeData, tMII.cch)
                  Else
                     sCap = ""
                  End If
                  tTR.top = 0
                  tTR.bottom = lHeight
                  tTR.left = 0: tTR.right = 0
                  DrawText lhDCC, sCap, -1, tTR, DT_CALCRECT
                  OffsetRect tTR, lX, 2
                  LSet tBR = tTR
                  InflateRect tBR, 2, 2
                  tBR.right = tBR.right + 7
                  m_iCount = m_iCount + 1
                  bPress = False
                  If m_iCount = m_iDownOn Then
                     ' This is the item that was clicked:
                     If m_iDownOn = m_iOver Then
                        ' Draw Pressed
                        'Debug.Print "DrawPressed"
                        bPress = True
                        SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
                        DrawEdge lhDCC, tBR, BDR_SUNKENOUTER, BF_RECT
                     Else
                        ' Draw Raised
                        'Debug.Print "DrawRaised"
                        SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
                        DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
                     End If
                  Else
                     ' Not down on, may be over:
                     If m_iCount = m_iOver Then
                        ' Draw Raised
                        'Debug.Print "DrawRaised"
                        SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
                        DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
                     Else
                        ' Draw None
                        SetTextColor lhDCC, TranslateColor(m_oActiveMenuColor)
                     End If
                  End If
                  If bPress Then
                     OffsetRect tTR, 1, 1
                  End If
                  DrawText lhDCC, sCap, -1, tTR, DT_LEFT Or DT_SINGLELINE
                  If bPress Then
                     OffsetRect tTR, -1, -1
                  End If
                  ReDim Preserve m_tR(1 To m_iCount) As RECT
                  ReDim Preserve m_hSubMenu(1 To m_iCount) As Long
                  OffsetRect tBR, lLeft, lYoffset
                  LSet m_tR(m_iCount) = tBR
                  m_hSubMenu(m_iCount) = GetSubMenu(m_hMenu, iIdx)
                  lX = lX + tTR.right - tTR.left + 1 + 10
               End If
            End If
         Next iIdx

         BitBlt lhDC, lLeft, lTop, lWidth, lHeight, lhDCC, 0, 0, vbSrcCopy

      End If
   
      SelectObject lhDCC, hFntOld
   End If
End Sub
'===================================================
'
'===================================================
Friend Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Boolean
Dim lC As Long
Dim iIdx As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim lR As Long
Dim sCap As String
Dim iPos As Long
Dim sAccel As String

   lC = GetMenuItemCount(m_hMenu)
   If lC > 0 Then
      For iIdx = 0 To lC - 1
         tMII.fMask = MIIM_TYPE Or MIIM_DATA
         tMII.cch = 127
         tMII.dwTypeData = String$(128, 0)
         tMII.cbSize = LenB(tMII)
         lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
         If tMII.cch > 0 Then
            sCap = left$(tMII.dwTypeData, tMII.cch)
            iPos = InStr(sCap, "&")
            If iPos > 0 And iPos < Len(sCap) Then
               sAccel = UCase$(Mid$(sCap, iPos + 1, 1))
               If sAccel = Chr$(vKey) Then
                  PressButton iIdx + 1, True
                  If Not m_cTmr Is Nothing Then
                     m_cTmr.Interval = 0
                  End If
                  lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
                  pRestoreList
                  AltKeyAccelerator = True
               End If
            End If
         End If
      Next iIdx
   End If
End Function
'===================================================
'
'===================================================
Private Function MenuHitTest() As Long

   If m_iCount > 0 Then
      Dim tP As POINTAPI
      GetCursorPos tP
      MenuHitTest = HitTest(tP)
   End If
   
End Function
'===================================================
'
'===================================================
Friend Function HitTest(tP As POINTAPI) As Long

   ' Is tP within a top level menu button? tP
   ' is in screen coords
   '
Dim iMenu As Long

   ScreenToClient m_hWnd, tP
   For iMenu = 1 To m_iCount
      'Debug.Print m_tR(iMenu).left, m_tR(iMenu).top, m_tR(iMenu).right, m_tR(iMenu).bottom, tP.x, tP.y
      If PtInRect(m_tR(iMenu), tP.x, tP.y) <> 0 Then
         HitTest = iMenu