cmenubar.cls

这是一个有VB开发的学院办公自动化系统

            Exit Function
         End If
      End If
   Next i
End Function
Private Function plAddToRestoreList(ByVal hMenu As Long, ByVal iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA) As Long
   
   ' Here we store information about a menu item.  When the
   ' menus are closed again we can reset things back to the
   ' way they were using this struct.

   m_iRestore = m_iRestore + 1
   ReDim Preserve m_hMenuRestore(1 To m_iRestore) As Long
   ReDim Preserve m_iMenuPosition(1 To m_iRestore) As Long
   ReDim Preserve m_tMIIS(1 To m_iRestore) As MENUITEMINFO_STRINGDATA
   ReDim Preserve m_sCaption(1 To m_iRestore) As String
   ReDim Preserve m_sShortCut(1 To m_iRestore) As String
   ReDim Preserve m_sAccelerator(1 To m_iRestore) As String
   ReDim Preserve m_lMenuTextSize(1 To m_iRestore) As Long
   ReDim Preserve m_lMenuShortCutSize(1 To m_iRestore) As Long
   pReplaceRestoreList m_iRestore, hMenu, iMenu, tMIIS
   plAddToRestoreList = m_iRestore

End Function
Private Sub pReplaceRestoreList(ByVal lIdx As Long, hMenu As Long, iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA)
Dim sCap As String
Dim sShortCut As String
Dim iPos As Long

   m_hMenuRestore(lIdx) = hMenu
   m_iMenuPosition(lIdx) = iMenu
   LSet m_tMIIS(lIdx) = tMIIS
   If tMIIS.cch > 0 Then
      sCap = left$(tMIIS.dwTypeData, tMIIS.cch)
   Else
      sCap = ""
   End If
   iPos = InStr(sCap, vbTab)
   If iPos > 0 Then
      m_sShortCut(lIdx) = Mid$(sCap, iPos + 1)
      m_sCaption(lIdx) = left$(sCap, iPos - 1)
   Else
      m_sCaption(lIdx) = sCap
      m_sShortCut(lIdx) = ""
   End If
   iPos = InStr(m_sCaption(lIdx), "&")
   If iPos > 0 And iPos < Len(m_sCaption(lIdx)) Then
      m_sAccelerator(lIdx) = UCase$(Mid$(m_sCaption(lIdx), iPos + 1, 1))
   End If
End Sub
Private Function InternalIDForWindowsID(ByVal wID As Long) As Long
Dim i As Long
   ' linear search I'm afraid, but it is only called once
   ' per menu item shown (when WM_MEASUREITEM is fired)
   For i = 1 To m_iRestore
      If m_tMIIS(i).wID = wID Then
         InternalIDForWindowsID = i
         Exit Function
      End If
   Next i
End Function
Friend Sub pRestoreList()
Dim i As Long
   'Debug.Print "RESTORELIST"
   ' erase the lot:
   For i = 1 To m_iRestore
      SetMenuItemInfoStr m_hMenuRestore(i), m_iMenuPosition(i), True, m_tMIIS(i)
   Next i
   m_iRestore = 0
   Erase m_hMenuRestore
   Erase m_iMenuPosition
   Erase m_tMIIS
   Erase m_sCaption()
   Erase m_sShortCut()
   Erase m_sAccelerator()
   m_iHaveSeenCount = 0
   Erase m_hMenuSeen()
End Sub

Private Sub Class_Initialize()
   Set m_cMemDC = New cMemDC
   Set m_fnt = New StdFont
   m_fnt.Name = "MS Sans Serif"
   Set m_fntSymbol = New StdFont
   m_fntSymbol.Name = "Marlett"
   m_fntSymbol.Size = m_fnt.Size * 1.2
End Sub

Private Sub Class_Terminate()
   Set m_cMemDC = Nothing
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   ISubclass_MsgResponse = emrConsume
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim iMenu As Long
Dim iLastDownOn As Long
Dim iLastOver As Long
Dim lR As Long
Dim lFlag As Long
Dim hMenu As Long
Dim iChar As Long

   Select Case iMsg
   Case WM_LBUTTONDOWN
      ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
      ' If in range, then...
      iMenu = MenuHitTest()
      iLastDownOn = m_iDownOn
      m_iDownOn = iMenu
      If m_iDownOn <> iLastDownOn Then
         ' !Repaint!
         'Debug.Print "Repaint"
         SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
      End If
      
      If m_iDownOn > 0 Then
         m_cTmr.Interval = 0
         lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
         pRestoreList
      End If
      
   Case WM_MOUSEMOVE
      ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
      pMouseMove
      
   Case WM_MEASUREITEM
      ISubclass_WindowProc = MeasureItem(wParam, lParam)
   
   Case WM_DRAWITEM
      DrawItem wParam, lParam
      
   Case WM_MENUCHAR
      ' Check that this is my menu:
      lFlag = wParam \ &H10000
      If ((lFlag And MF_SYSMENU) <> MF_SYSMENU) Then
         hMenu = lParam
         iChar = (wParam And &HFFFF&)
         ' See if this corresponds to an accelerator on the menu:
         lR = ParseMenuChar(hMenu, iChar)
         If lR > 0 Then
            ISubclass_WindowProc = lR
            Exit Function
         End If
      End If
      ISubclass_WindowProc = CallOldWindowProc(m_hWnd, WM_MENUCHAR, wParam, lParam)
   
   End Select
   
End Function
Private Function ParseMenuChar( _
        ByVal hMenu As Long, _
        ByVal iChar As Integer _
    ) As Long
Dim sChar As String
Dim l As Long
Dim lH() As Long
Dim sItems() As String

   'Debug.Print "WM_MENUCHAR"
   sChar = UCase$(Chr$(iChar))
   For l = 1 To m_iRestore
      If (m_hMenuRestore(l) = hMenu) Then
         If (m_sAccelerator(l) = sChar) Then
            ParseMenuChar = &H20000 Or m_iMenuPosition(l)
            ' Debug.Print "Found Menu Char"
            Exit Function
         End If
      End If
   Next l

End Function

Private Function MeasureItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMIS As MEASUREITEMSTRUCT
Dim lID As Long
   CopyMemory tMIS, ByVal lParam, LenB(tMIS)
   If tMIS.CtlType = ODT_MENU Then
                  
      ' because we don't get the popup menu handle
      ' in the tMIS structure, we have to do an internal
      ' lookup to find info about this menu item.
      ' poor implementation of MEASUREITEMSTRUCT - it
      ' should have a .hWndItem field like DRAWITEMSTRUCT
      ' - spm
      lID = InternalIDForWindowsID(tMIS.itemID)
            
      ' Width:
      tMIS.itemWidth = 4 + 22 + m_lMenuTextSize(lID) + 4
      If m_lMenuShortCutSize(lID) > 0 Then
         tMIS.itemWidth = tMIS.itemWidth + 4 + m_lMenuShortCutSize(lID) + 4
      End If
      
      ' Height:
      If lID > 0 And lID <= m_iRestore Then
         If (m_tMIIS(lID).fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
            tMIS.itemHeight = 6
         Else
            ' menu item height is always the same
            tMIS.itemHeight = m_lMenuItemHeight + 8
         End If
      Else
         ' problem.
      End If
      
      CopyMemory ByVal lParam, tMIS, LenB(tMIS)
      
   Else
      MeasureItem = CallOldWindowProc(m_hWnd, WM_MEASUREITEM, wParam, lParam)
   End If
End Function
Private Function DrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tDIS As DRAWITEMSTRUCT
Dim hBr As Long
Dim tR As RECT, tTR As RECT, tWR As RECT
Dim lhDC As Long
Dim hFntOld As Long
Dim tMII As MENUITEMINFO
Dim bRadioCheck As Boolean, bDisabled As Boolean, bChecked As Boolean, bHighlighted As Boolean
Dim lID As Long
Dim hFntS As Long, hFntSOld As Long

   CopyMemory tDIS, ByVal lParam, LenB(tDIS)
   If tDIS.CtlType = ODT_MENU Then
      ' Todo
      ' tDIS.hWndItem is the menu containing the item, tDIS.itemID is the wID
      
      m_cMemDC.Width = tDIS.rcItem.right - tDIS.rcItem.left + 1
      m_cMemDC.Height = tDIS.rcItem.bottom - tDIS.rcItem.top + 1
      lhDC = m_cMemDC.hdc
      hFntOld = SelectObject(lhDC, hFont)
      
      LSet tR = tDIS.rcItem
      OffsetRect tR, -tR.left, -tR.top
      
      ' Fill background:
      tTR.right = m_cMemDC.Width
      tTR.bottom = m_cMemDC.Height
      hBr = CreateSolidBrush(TranslateColor(m_oMenuBackgroundColor))
      FillRect lhDC, tTR, hBr
      DeleteObject hBr
      
      SetBkMode lhDC, TRANSPARENT
      
      ' Draw the text:
      tMII.cbSize = LenB(tMII)
      tMII.fMask = MIIM_TYPE Or MIIM_STATE Or MIIM_DATA
      GetMenuItemInfo tDIS.hwndItem, tDIS.itemID, False, tMII
      
      If (tMII.fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
         ' Separator:
         LSet tWR = tR
         tWR.top = (tWR.bottom - tWR.top - 2) \ 2 + tWR.top
         tWR.bottom = tWR.top + 2
         InflateRect tWR, -8, 0
         DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM
      Else
         ' Text item:
         bRadioCheck = ((tMII.fType And MFT_RADIOCHECK) = MFT_RADIOCHECK)
         bDisabled = ((tMII.fState And MFS_DISABLED) = MFS_DISABLED)
         bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
         bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
         If bHighlighted Then
            SetTextColor lhDC, TranslateColor(m_oActiveMenuColorOver)
         Else
            SetTextColor lhDC, TranslateColor(m_oActiveMenuColor)
         End If
         
         ' Check:
         If bChecked Then
            LSet tWR = tR
            InflateRect tWR, -4, -4
            tWR.left = tWR.left + 2
            tWR.right = tWR.left + (tWR.bottom - tWR.top + 1)
            DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_RECT
            
            SelectObject lhDC, hFntOld
            hFntSOld = SelectObject(lhDC, hFontSymbol)
            If bRadioCheck Then
               pDrawItem lhDC, "h", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
            Else
               pDrawItem lhDC, "b", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
            End If
            SelectObject lhDC, hFntSOld
            hFntOld = SelectObject(lhDC, hFont)
            
         End If
         
         ' Draw text:
         LSet tWR = tR
         tWR.left = 20 + 4
         lID = tMII.dwItemData
         If lID > 0 And lID <= m_iRestore Then
            pDrawItem lhDC, m_sCaption(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            If Len(m_sShortCut(lID)) > 0 Then
               tWR.left = tWR.left + m_lMenuTextSize(lID) + 4 + 4
               pDrawItem lhDC, m_sShortCut(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            End If
         End If
         
         ' Highlighted:
         If bHighlighted And Not (bDisabled) Then
            LSet tWR = tR
            InflateRect tWR, -2, 0
            DrawEdge lhDC, tWR, BDR_RAISEDINNER, BF_RECT
         End If
         
      End If
      
      SelectObject lhDC, hFntOld
      
      BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, tDIS.rcItem.right - tDIS.rcItem.left + 1, tDIS.rcItem.bottom - tDIS.rcItem.top + 1, lhDC, 0, 0, vbSrcCopy
      
   Else
      DrawItem = CallOldWindowProc(m_hWnd, WM_DRAWITEM, wParam, lParam)
   End If
End Function
Private Sub pDrawItem( _
      ByVal lhDC As Long, _
      ByVal sText As String, _
      ByRef tR As RECT, _
      ByVal bDisabled As Boolean, _
      ByVal dtFlags As Long _
   )
Dim tWR As RECT
   LSet tWR = tR
   If bDisabled Then
      SetTextColor lhDC, TranslateColor(vb3DHighlight)
      OffsetRect tWR, 1, 1
      DrawText lhDC, sText, -1, tWR, dtFlags
      SetTextColor lhDC, TranslateColor(vbButtonShadow)
      OffsetRect tWR, -1, -1
      DrawText lhDC, sText, -1, tWR, dtFlags
   Else
      DrawText lhDC, sText, -1, tWR, dtFlags
   End If
End Sub
Private Sub pMouseMove()
Dim iMenu As Long
Dim iLastOver As Long
   iMenu = MenuHitTest()
   iLastOver = m_iOver
   m_iOver = iMenu
   'Debug.Print "Over:", m_iOver, iLastOver
   If m_iOver <> iLastOver Then
      ' !Repaint!
      'Debug.Print "Repaint"
      SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
   End If
   If m_cTmr Is Nothing Then
      Set m_cTmr = New CTimer
   End If
   If m_iOver < 1 And m_iDownOn = 0 Then
      m_cTmr.Interval = 0
   Else
      If m_iDownOn > 0 Then
         If GetAsyncKeyState(vbLeftButton) = 0 Then
            m_iDownOn = 0
            SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
         End If
      End If
      m_cTmr.Interval = 50
   End If
End Sub

Private Sub m_cTmr_ThatTime()
   pMouseMove
End Sub
' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function