?? cmenubar.cls
字號(hào):
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
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號(hào)
Ctrl + =
減小字號(hào)
Ctrl + -