ctxhookmenu.ctl

很美的窗口控件,让你的系统界面接近WINDOWS界面...不信你

        m_clrDisabledMenuFore = vbGrayText
        If pvIsAppearanceXpStyle() Then
            m_clrMenuBarBack = GetSysColor(COLOR_MENUBAR)
        Else
            m_clrMenuBarBack = vbMenuBar
        End If
        m_clrMenuPopupBack = vbWindowBackground
    Else
        '--- calc normal colors
        m_clrSelMenuBorder = vbHighlight
        m_clrSelMenuBack = pvAlphaBlend(vbHighlight, vbWindowBackground, 70)
        m_clrSelMenuFore = vbMenuText
        m_clrCheckBack = pvAlphaBlend(vbWindowBackground, m_clrSelMenuBack, 128)
        m_clrCheckFore = m_clrSelMenuFore
        m_clrSelCheckBack = pvAlphaBlend(pvAlphaBlend(vbHighlight, m_clrSelMenuBack, 128), m_clrSelMenuBack, 128)
        m_clrMenuBorder = vbButtonShadow
        m_clrMenuBack = pvAlphaBlend(vbButtonFace, vbWindowBackground, 214)
        m_clrMenuFore = vbWindowText
        m_clrDisabledMenuBorder = vbButtonShadow
        m_clrDisabledMenuBack = pvAlphaBlend(m_clrMenuBack, vbWindowBackground, 128)
        m_clrDisabledMenuFore = vbGrayText
        If pvIsAppearanceXpStyle Then
            m_clrMenuBarBack = GetSysColor(COLOR_MENUBAR)
        Else
            m_clrMenuBarBack = vbMenuBar
        End If
        m_clrMenuPopupBack = vbWindowBackground
    End If
    '--- calc menu item height
    With New cMemDC
        .Init
        If UseSystemFont Then
            Set .Font = .SystemMenuFont
        Else
            Set .Font = Font
        End If
        m_lTextHeight = .TextHeight("ABCH") + 7
        m_lMenuHeight = m_lTextHeight
        '--- min space for icons
        If m_lMenuHeight < BitmapSize + 7 Then
            m_lMenuHeight = BitmapSize + 7
        End If
    End With
    '--- (re)init menu
    Call pvInitMenu(m_hFormMenu, True)
End Sub

Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
    Dim clrFore         As UcsRgbQuad
    Dim clrBack         As UcsRgbQuad
    
    OleTranslateColor clrFirst, 0, VarPtr(clrFore)
    OleTranslateColor clrSecond, 0, VarPtr(clrBack)
    With clrFore
        .R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
        .G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
        .b = (.b * lAlpha + clrBack.b * (255 - lAlpha)) / 255
    End With
    CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function

Private Function pvSetMenuInfo(ByVal hMenu As Long, sText As String, ByVal lType As Long, ByVal bMainMenu As Boolean, ByVal lId As Long) As Long
    m_cMenuInfo.Add hMenu & Chr(1) & sText & Chr(1) & lType & Chr(1) & Abs(bMainMenu) & Chr(1) & lId
    pvSetMenuInfo = m_cMenuInfo.Count
End Function

Private Sub pvGetMenuInfo(ByVal lIdx As Long, hMenu As Long, sText As String, lType As Long, bMainMenu As Boolean, lId As Long)
    Dim vSplit          As Variant
    
    On Error Resume Next
    vSplit = Split(m_cMenuInfo(lIdx), Chr(1))
    hMenu = vSplit(0)
    sText = vSplit(1)
    lType = vSplit(2)
    bMainMenu = vSplit(3) <> 0
    lId = vSplit(4)
End Sub

Private Function pvGetMdiChild() As Long
    If Not m_oClientSubclass Is Nothing Then
        If m_oClientSubclass.hwnd <> 0 Then
            pvGetMdiChild = m_oClientSubclass.CallOrigWndProc(WM_MDIGETACTIVE, 0, 0)
        End If
    End If
End Function

Private Property Get OsVersion() As Long
    Static lVersion     As Long
    Dim uVer            As OSVERSIONINFO
    
    If lVersion = 0 Then
        uVer.dwOSVersionInfoSize = Len(uVer)
        If GetVersionEx(uVer) Then
            lVersion = uVer.dwMajorVersion * &H100 + uVer.dwMinorVersion
        End If
    End If
    OsVersion = lVersion
End Property

Private Property Get IsNT() As Boolean
    Static lPlatform    As Long
    Dim uVer            As OSVERSIONINFO
    
    If lPlatform = 0 Then
        uVer.dwOSVersionInfoSize = Len(uVer)
        If GetVersionEx(uVer) Then
            lPlatform = uVer.dwPlatformId
        End If
    End If
    IsNT = (lPlatform = VER_PLATFORM_WIN32_NT)
End Property

Private Function pvRegGetKeyValue( _
            lKeyRoot As Long, _
            sKeyName As String, _
            sValueName As String) As String
    Dim hr              As Long
    Dim hKey            As Long
    Dim sValue          As String
    Dim lValType        As Long
    Dim lValSize        As Long
    
    '--- open key
    hr = RegOpenKeyEx(lKeyRoot, sKeyName, 0, KEY_QUERY_VALUE, hKey)
    If hr <> 0 Then
        Exit Function
    End If
    '--- query value size
    lValSize = 0
    hr = RegQueryValueEx(hKey, sValueName, 0, lValType, vbNullString, lValSize)
    If hr <> 0 Then
        Call RegCloseKey(hKey)
        Exit Function
    End If
    '--- get value
    sValue = String(lValSize + 1, 0)
    lValSize = Len(sValue)
    hr = RegQueryValueEx(hKey, sValueName, 0, lValType, sValue, lValSize)
    If hr <> 0 Then
        Call RegCloseKey(hKey)
        Exit Function
    End If
    '--- close key
    Call RegCloseKey(hKey)
    '--- ret value and trim
    If lValSize > 0 Then
        If (AscB(MidB(sValue, lValSize, 1)) = 0) Then
            pvRegGetKeyValue = Left(sValue, lValSize - 1)
        Else
            pvRegGetKeyValue = Left(sValue, lValSize)
        End If
    End If
End Function

Private Sub pvInitMenu(ByVal hMenu As Long, ByVal bMainMenu As Boolean)
    Dim mii             As MENUITEMINFO
    Dim lIdx            As Long
    Dim hMdiChild       As Long
    Dim sBuffer         As String
    
    On Error GoTo EH
    If hMenu <> 0 Then
        '--- first, forward to child MDI window
        hMdiChild = pvGetMdiChild
        If hMdiChild <> 0 Then
            If SendMessage(hMdiChild, pvInitMenuMsg, IIf(hMenu = m_hFormMenu, ucsIniMainMenu, ucsIniMenu), hMenu) = 1 Then
                Exit Sub
            End If
        End If
        '--- then process locally
        sBuffer = String(1024, 0)
        For lIdx = 0 To GetMenuItemCount(hMenu) - 1
            With mii
                '--- get item info
                If OsVersion >= &H40A Then '--- &H40A = win98 and later
                    .cbSize = Len(mii)
                    .fMask = MIIM_ID Or MIIM_FTYPE Or MIIM_DATA Or MIIM_STRING
                Else
                    .cbSize = Len(mii) - 4
                    .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_DATA
                End If
                .dwTypeData = StrPtr(sBuffer)
                .cch = Len(sBuffer)
                Call GetMenuItemInfo(hMenu, lIdx, 1, mii)
                '--- store info (if not stored already)
                If (.fType And MFT_OWNERDRAW) = 0 Then
                    .dwItemData = pvSetMenuInfo(hMenu, Left(StrConv(sBuffer, vbUnicode), .cch), .fType, bMainMenu, .wID) '--- save hMenu
                End If
                '--- set ownerdrawn & itemdata, clear bitmap
                If OsVersion >= &H40A Then
                    .cbSize = Len(mii)
                    .fMask = MIIM_FTYPE Or MIIM_DATA Or MIIM_BITMAP
                    .hbmpItem = 0
                Else
                    .cbSize = Len(mii) - 4
                    .fMask = MIIM_TYPE Or MIIM_DATA
                End If
                .fType = (.fType And (MFT_SEPARATOR Or MFT_RIGHTJUSTIFY)) Or MFT_OWNERDRAW
                Call SetMenuItemInfo(hMenu, lIdx, 1, mii)
            End With
        Next
    End If
    #If WEAK_REF_CURRENTMENU Then
        CopyMemory VarPtr(g_oCurrentMenu), VarPtr(Me), 4
    #Else
        Set g_oCurrentMenu = Me
    #End If
    Exit Sub
EH:
    Debug.Print "Error in pvInitMenu: "; Error
    Resume Next
End Sub

Private Sub pvRestoreMenus(ByVal hMenu As Long)
    Dim hCurMenu        As Long
    Dim sText           As String
    Dim lType           As Long
    Dim bMainMenu       As Boolean
    Dim lId             As Long
    Dim mii             As MENUITEMINFO
    Dim lIdx            As Long
    
    lIdx = 1
    Do While m_cMenuInfo.Count >= lIdx
        pvGetMenuInfo lIdx, hCurMenu, sText, lType, bMainMenu, lId
        If hCurMenu <> hMenu And hMenu <> 0 Then
            lIdx = lIdx + 1
        Else
            With mii
                If OsVersion >= &H40A Then
                    .cbSize = Len(mii)
                    .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_DATA
                    .hbmpItem = 0
                Else
                    .cbSize = Len(mii) - 4
                    .fMask = MIIM_TYPE Or MIIM_DATA
                End If
                sText = StrConv(sText, vbFromUnicode)
                .dwTypeData = StrPtr(sText)
                .cch = Len(sText)
                .fType = lType
                Call SetMenuItemInfo(hCurMenu, lId, 0, mii)
            End With
            Call m_cMenuInfo.Remove(lIdx)
        End If
    Loop
End Sub

Friend Sub frSubclassPopup(ByVal hwnd As Long)
    Dim oSubclass       As cSubclassingThunk
    Dim lStyle          As Long
    Dim lExStyle        As Long
    
    On Error Resume Next
    '--- check if this is a popup menu from main menubar
    If Not m_bExpectingPopup Then
        Exit Sub
    End If
    Set oSubclass = m_cMenuSubclass("#" & hwnd)
    If oSubclass Is Nothing Then
        Set oSubclass = New cSubclassingThunk
        With oSubclass
            #If WEAK_REF_ME Then
                .Subclass hwnd, Me, True, True
            #Else
                .Subclass hwnd, Me, False, True
            #End If
            .AddBeforeMsgs WM_ERASEBKGND, WM_NCCALCSIZE, WM_NCPAINT, _
                        WM_WINDOWPOSCHANGING, WM_PRINT, WM_SHOWWINDOW, WM_DESTROY
        End With
        m_cMenuSubclass.Add oSubclass, "#" & hwnd
    End If
    '--- fix styles
    lExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    oSubclass.Tag = Array(lStyle, lExStyle)
    SetWindowLong hwnd, GWL_EXSTYLE, lExStyle And (Not WS_EX_DLGMODALFRAME) And (Not WS_EX_WINDOWEDGE)
    SetWindowLong hwnd, GWL_STYLE, lStyle And (Not WS_BORDER)
    lStyle = GetClassLong(hwnd, GCL_STYLE)
    '--- win98: check if anything to modify
    If (lStyle And CS_DROPSHADOW) <> 0 Then
        SetClassLong hwnd, GCL_STYLE, lStyle And (Not CS_DROPSHADOW)
    End If
    SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_FLAGS
End Sub

Private Function pvMeasureItem(ByVal lParam As Long) As Boolean
    Dim mis             As MEASUREITEMSTRUCT
    Dim mii             As MENUITEMINFO
    Dim vSplit          As Variant
    Dim hMenu           As Long
    Dim sText           As String
    Dim lType           As Long
    Dim bMainMenu       As Boolean
    Dim lId             As Long
    Dim lRight          As Long
    
    '--- dereference structure
    CopyMemory VarPtr(mis), lParam, Len(mis)
    If mis.CtlType = ODT_MENU Then
        '--- get menu info
        Call pvGetMenuInfo(mis.itemData, hMenu, sText, lType, bMainMenu, lId)