cmenubar.cls

来自「非常漂亮的VB控件」· CLS 代码 · 共 1,299 行 · 第 1/4 页

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 Mstyle As Integer
Private m_lMenuItemHeight As Long
Private M_Msstyle 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 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, ByVal Mst As Integer)
   Mstyle = Mst
   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  ' 菜单栏按钮的TOP
         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.bottom = lHeight + 1
                  tTR.right = 0
                  tTR.left = 0: tTR.top = 0
                  DrawText lhDCC, sCap, -1, tTR, DT_CALCRECT
                  OffsetRect tTR, lX, 2
                  LSet tBR = tTR
                  InflateRect tBR, 2, 2
                  tBR.left = tBR.left - 2
                  tBR.right = tBR.right + 2 '设置Menu按钮的最右边位置
                  tBR.bottom = tBR.bottom + 1
                  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)
                        
                        'If Mstyle = 0 Then
                       ' DrawEdge lhDCC, tBR, &H4, BF_RECT '主菜单按下后的样式
                       ' tBR.left = tBR.left + 2: tBR.bottom = tBR.bottom
                       ' tBR.right = tBR.right - 2: tBR.top = tBR.top + 2
                       ' DrawEdge lhDCC, tBR, &H2, BF_RECT '主菜单按下后的样式
                      '  Else
                     ' tTR.left = 0: tTR.top = 0
                        DrawEdge lhDCC, tBR, &H4, 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)
                      'tTR.left = 0: tTR.top = 0
                        DrawEdge lhDCC, tBR, &H5, 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
               BitBlt lhDC, lLeft, lTop, lWidth, lHeight, lhDCC, 0, 0, vbSrcCopy '画窗口菜单的图片
            End If
         Next iIdx
      End If
   
      SelectObject lhDCC, hFntOld
   End If
End Sub
Friend Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
Dim tRW As RECT
   If iButton > 0 And iButton <= m_iCount Then
      LSet tR = m_tR(iButton)
      GetWindowRect m_hWnd, tRW
      OffsetRect tR, tRW.left - 1, tRW.top + m_lCaptionHeight + 3
   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
         Exit Function
      End If
   Next iMenu
End Function
Friend Property Get Count() As Long
   
   ' Number of top level menu items:?
   '
   Count = m_iCount
   
End Property
Friend Function GetMenuHandle(ByVal iNewPopup As Long) As Long
   
   ' Returns the popup menu handle for a given top level
   ' menu item (1 based index)
   '
   If iNewPopup > 0 And iNewPopup <= m_iCount Then
      GetMenuHandle = m_hSubMenu(iNewPopup)
   End If
End Function
Friend Property Get HotItem() As Long
   '
   HotItem = m_iDownOn
End Property
Friend Property Let HotItem(ByVal iHotItem As Long)
   ' Set the hotitem
   m_iOver = iHotItem
   ' Repaint:
   SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End Property

Friend Sub OwnerDrawMenu(ByVal hMenu As Long)
Dim lC As Long
Dim tMIIS As MENUITEMINFO_STRINGDATA
Dim tMII As MENUITEMINFO
Dim iMenu As Long
Dim sCap As String
Dim sShortCut As String
Dim tR As RECT
Dim iPos As Long
Dim lID As Long
Dim bHaveSeen As Boolean
Dim hFntOld As Long
Dim lMenuTextSize As Long
Dim lMenuShortCutSize As Long
Dim I As Long
                  
   ' Set OD flag on the fly...
   bHaveSeen = pbHaveSeen(hMenu)

   hFntOld = SelectObject(m_cMemDC.hdc, hFont)