cmenubar.cls

Visual basic 数据库编程技术与实例源码 源码

   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
         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 Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
   '
   If bState Then
      m_iDownOn = iButton
   Else
      If m_iDownOn = iButton Then
         m_iDownOn = -1
      End If
   End If
   SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
   
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, tRW.top + m_lCaptionHeight
   End If
End Sub
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)
   lC = GetMenuItemCount(hMenu)
   For iMenu = 0 To lC - 1
      
      If Not bHaveSeen Then
               
         tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
         tMIIS.cch = 127
         tMIIS.dwTypeData = String$(128, 0)
         tMIIS.cbSize = LenB(tMIIS)
         GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
         'Debug.Print "New Item", tMIIS.dwTypeData
         
         lID = plAddToRestoreList(hMenu, iMenu, tMIIS)
      
         If Not (tMIIS.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW Then
            ' Setting this flag causes tMIIS.dwTypeData to be
            ' overwritten with our own app-defined value:
            tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
            tMII.dwItemData = lID
            tMII.cbSize = LenB(tMII)
            tMII.fMask = MIIM_TYPE Or MIIM_DATA
            SetMenuItemInfo hMenu, iMenu, True, tMII
         End If
      
      Else
         
         tMII.fMask = MIIM_TYPE Or MIIM_DATA
         tMII.cbSize = Len(tMII)
         GetMenuItemInfo hMenu, iMenu, True, tMII
         lID = tMII.dwItemData
         
         If Not ((tMII.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW) Then
            
            lID = plReplaceIndex(hMenu, iMenu)
         
            'Debug.Print "VB has done something to it!", lID
            tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
            tMIIS.cch = 127
            tMIIS.dwTypeData = String$(128, 0)
            tMIIS.cbSize = LenB(tMIIS)
            GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
            
            pReplaceRestoreList lID, hMenu, iMenu, tMIIS
            
            ' Setting this flag causes tMIIS.dwTypeData to be
            ' overwritten with our own app-defined value:
            tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
            tMII.dwItemData = lID
            tMII.cbSize = LenB(tMII)
            tMII.fMask = MIIM_TYPE Or MIIM_DATA
            SetMenuItemInfo hMenu, iMenu, True, tMII
            
         End If
         
      End If
                              
      If lID > 0 And lID <= m_iRestore Then
         sCap = m_sCaption(lID)
         sShortCut = m_sShortCut(lID)
         
         'Debug.Print m_sCaption(lID), m_sShortCut(lID)
         
         DrawText m_cMemDC.hdc, sCap, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
         If tR.right - tR.left + 1 > lMenuTextSize Then
            lMenuTextSize = tR.right - tR.left + 1
         End If
         If Len(sShortCut) > 0 Then
            DrawText m_cMemDC.hdc, sShortCut, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
            If tR.right - tR.left + 1 > lMenuShortCutSize Then
               lMenuShortCutSize = tR.right - tR.left + 1
            End If
         End If
         m_lMenuItemHeight = tR.bottom - tR.top + 1
         
      Else
         'Debug.Print "ERROR! ERROR! ERROR!"
      End If
      
   Next iMenu
   
   For i = 1 To m_iRestore
      If m_hMenuRestore(i) = hMenu Then
         m_lMenuTextSize(i) = lMenuTextSize
         m_lMenuShortCutSize(i) = lMenuShortCutSize
      End If
   Next i
   
   SelectObject m_cMemDC.hdc, hFntOld
   
End Sub
Private Function pbHaveSeen(ByVal hMenu As Long) As Boolean
   
   ' When WM_INITMENUPOPUP fires, this may or not be
   ' a new menu.  We use an array to store which menus
   ' we've already worked on:

Dim i As Long
   
   For i = 1 To m_iHaveSeenCount
      If hMenu = m_hMenuSeen(i) Then
         pbHaveSeen = True
         Exit Function
      End If
   Next i
   m_iHaveSeenCount = m_iHaveSeenCount + 1
   ReDim Preserve m_hMenuSeen(1 To m_iHaveSeenCount) As Long
   m_hMenuSeen(m_iHaveSeenCount) = hMenu

End Function
Private Function plReplaceIndex(ByVal hMenu As Long, ByVal iMenu As Long)
Dim i As Long
   For i = 1 To m_iRestore
      If m_hMenuRestore(i) = hMenu Then
         If m_iMenuPosition(i) = iMenu Then
            plReplaceIndex = i