modcoolmenu.bas

入侵检测是近几年发展起来的新型网络安全策略

            Call SetBkMode(hdc&, OPAQUE)
            Call SetTextColor(hdc&, GetSysColor(COLOR_BTNLIGHT))
            Call DrawText(hdc&, " " + pmd.sMenuText + " ", 2 + Len(pmd.sMenuText), rtText, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
            rtText = OffsetRect(rtText, -1, -1)
            Call SetBkMode(hdc&, TRANSPARENT)
            Call SetTextColor(hdc&, GetSysColor(COLOR_BTNSHADOW))
            Call DrawText(hdc&, " " + pmd.sMenuText + " ", 2 + Len(pmd.sMenuText), rtText, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
            Call SelectObject(hdc&, OldFont&)
        End If
    ElseIf Left(pmd.sMenuText, 1) = "!" Then
        Dim SideBitmap As Long
        Dim sBitmap As String: sBitmap = "c:\win95\bureau\smart.bmp" + Chr(0)
        Dim hmemDC As Long
        Dim hOldBitmap As Long
    Else
        bDisabled = lpds.itemState And ODS_GRAYED
        bSelected = lpds.itemState And ODS_SELECTED
        bChecked = lpds.itemState And ODS_CHECKED
        bHaveButn = False
        iButton = pmd.iButton
        LSet rtButn = rtItem
        If WndObj.RightToLeft Then
            rtButn.Left = rtButn.Right - (m_iBitmapWidth + CXBUTTONMARGIN)
        Else
            rtButn.Right = rtButn.Left + m_iBitmapWidth + CXBUTTONMARGIN
        End If
        If iButton >= 0 Then
            bHaveButn = True
            rtIcon.Left = rtButn.Left + (CXBUTTONMARGIN \ 2)
            rtIcon.Right = rtIcon.Left + m_iBitmapWidth
            rtIcon.Top = rtButn.Top + ((rtButn.Bottom - rtButn.Top) - m_iBitmapWidth) \ 2
            rtIcon.Bottom = rtIcon.Top + m_iBitmapWidth
            If Not bDisabled Then
                Call FillRectEx(hdc&, rtButn, GetSysColor(IIf(bChecked And (Not bSelected), COLOR_BTNLIGHT, COLOR_MENU)))
                If bSelected Or bChecked Then Call DrawEdge(hdc&, rtButn, IIf(bChecked, BDR_SUNKENOUTER, BDR_RAISEDINNER), BF_RECT)
                Set pic = ConvertTo16(LoadResPicture(PrepTextForImage(pmd.sMenuText), vbResIcon).Handle)
                hIcon = pic.Handle
                Call DrawState(hdc&, 0&, 0&, hIcon&, 0&, rtIcon.Left, rtIcon.Top, rtIcon.Left, rtIcon.Top, DST_ICON Or DSS_NORMAL)
            Else
                Set pic = ConvertTo16(LoadResPicture(PrepTextForImage(pmd.sMenuText), vbResIcon).Handle)
                hIcon = pic.Handle
                Call DrawState(hdc&, 0&, 0&, hIcon&, 0&, rtIcon.Left, rtIcon.Top, rtIcon.Left + m_iBitmapWidth%, rtIcon.Top + m_iBitmapWidth%, DST_ICON Or DSS_DISABLED)
            End If
        Else
            info.cbSize = LenB(info)
            info.fMask = MIIM_CHECKMARKS
            Call GetMenuItemInfo(lpds.hwndItem, lpds.itemID, MF_BYCOMMAND, info)
            If bChecked Or CBool(info.hbmpUnchecked) Or (pmd.bAsMark And WndObj.ComplexChecks) Then
                bHaveButn = Draw3DMark(hwnd&, hdc&, rtButn, bChecked, bSelected, bDisabled, IIf(bChecked, info.hbmpChecked, info.hbmpUnchecked), pmd.bAsCheck)
            End If
        End If
        iButnWidth% = m_iBitmapWidth% + CXBUTTONMARGIN
        dwColorBG = IIf(bSelected And WndObj.FullSelect, WndObj.SelectColor&, GetSysColor(COLOR_MENU))
        LSet rtText = rtItem
        If pmd.bMainMenu Then Call FillRectEx(hdc&, rtItem, GetSysColor(COLOR_MENU))
        If (bSelected Or (lpds.itemAction = ODA_SELECT)) And (Not bDisabled) Then
            LSet rtHighlight = rtItem
            If bHaveButn Then
                If WndObj.RightToLeft Then
                    rtHighlight.Right = rtItem.Right - (iButnWidth% + CXGAP)
                Else
                    rtHighlight.Left = rtItem.Left + iButnWidth% + CXGAP
                End If
            End If
            If pmd.bMainMenu And bSelected Then
                rtText = OffsetRect(rtText, 2, 1)
                Call DrawEdge(hdc&, rtHighlight, BDR_SUNKENOUTER, BF_RECT)
            Else
                Call FillRectEx(hdc&, rtHighlight, dwColorBG&)
            End If
        End If
        If Not pmd.bMainMenu Then
            If WndObj.RightToLeft Then
                rtText.Right = rtItem.Right - (iButnWidth% + CXGAP + CXTEXTMARGIN)
                rtText.Left = rtItem.Left + iButnWidth%
            Else
                rtText.Left = rtItem.Left + iButnWidth% + CXGAP + CXTEXTMARGIN
                rtText.Right = rtItem.Right - iButnWidth%
            End If
        End If
        Call SetBkMode(hdc&, TRANSPARENT)
        dwSelTextColor& = GetSysColor(COLOR_HIGHLIGHTTEXT)
        dwColorText& = IIf(bDisabled, GetSysColor(COLOR_GRAYTEXT), IIf(bSelected And (Not pmd.bMainMenu), IIf(WndObj.FullSelect, dwSelTextColor&, WndObj.SelectColor&), IIf(WndObj.ForeColor& = 0&, GetSysColor(COLOR_MENUTEXT), WndObj.ForeColor&)))
        TextOffset = 1
        If bDisabled Then Call DrawMenuText(hwnd&, hdc&, OffsetRect(rtText, TextOffset, TextOffset), pmds(CStr(dwItemData)).sMenuText, GetSysColor(COLOR_BTNHIGHLIGHT), Not pmd.bMainMenu, WndObj.RightToLeft)
        Call DrawMenuText(hwnd&, hdc&, rtText, pmd.sMenuText, dwColorText&, Not pmd.bMainMenu, WndObj.RightToLeft)
    End If
    If pmd.bTrueSub Then
        LSet rtArrow = rtItem
        If WndObj.RightToLeft Then
            rtArrow.Left = rtArrow.Left + CXTEXTMARGIN
        Else
            rtArrow.Right = rtArrow.Right - CXTEXTMARGIN
        End If
        rtArrow.Top = rtArrow.Top + CXTEXTMARGIN
        Call PrintGlyph(hdc&, IIf(WndObj.RightToLeft, "3", "4"), dwColorText&, rtArrow, IIf(WndObj.RightToLeft, DT_LEFT, DT_RIGHT) Or DT_TOP Or DT_SINGLELINE)
        Call ExcludeClipRect(hdc&, rtItem.Left, rtItem.Top, rtItem.Right, rtItem.Bottom)
    End If
    Call CopyMemory(ByVal dsPtr&, lpds, Len(lpds))
    Set WndObj = Nothing
    OnDrawItem = True
    Exit Function
ErrHandler:
    Debug.Print Err.Number; Err.Description; " OnDrawItem"
    Err.Clear
End Function
Private Function OnMeasureItem(hwnd As Long, ByRef miPtr As Long) As Boolean
    Dim lpms                    As MEASUREITEMSTRUCT
    Dim dwItemData              As Long
    Dim rc                      As RECT
    Dim rcHeight                As Integer
    Dim OldFont                 As Long
    Dim hWndDC                  As Long
    Dim pmd                     As clsMyItemData
    Dim iCYMENU                 As Integer
    Dim itemWidth               As Long
    Call CopyMemory(lpms, ByVal miPtr, Len(lpms))
    dwItemData& = lpms.ItemData
    If (dwItemData& = 0&) Or (lpms.CtlType <> ODT_MENU) Then
        OnMeasureItem = False
        Exit Function
    End If
    Set pmd = pmds.Item(CStr(dwItemData&))
    iCYMENU% = GetSystemMetrics(SM_CYMENU)
    If pmd.fType And MFT_SEPARATOR Then
        hWndDC& = GetDC(hwnd&)
        OldFont& = SelectObject(hWndDC&, GetMenuFont(hwnd&))
        rcHeight = DrawText(hWndDC&, "A", 1&, rc, DT_SINGLELINE Or DT_CALCRECT) + 1
        lpms.itemHeight = IIf(iCYMENU% \ 2 > rcHeight, iCYMENU% \ 2, rcHeight)
        lpms.itemWidth = 0
        Call SelectObject(hWndDC&, OldFont&)
        Call ReleaseDC(hwnd&, hWndDC&)
    ElseIf Left(pmd.sMenuText, 1) = "!" Then
        lpms.itemHeight = 0
        lpms.itemWidth = 0
    Else
        hWndDC& = GetDC(hwnd&)
        OldFont& = SelectObject(hWndDC&, GetMenuFont(hwnd&))
        Call DrawText(hWndDC&, pmd.sMenuText, Len(pmd.sMenuText), rc, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT) 'Or DT_VCENTER
        Call SelectObject(hWndDC&, OldFont&)
        Call ReleaseDC(hwnd&, hWndDC&)
        rcHeight = rc.Bottom - rc.Top
        lpms.itemHeight = IIf(rcHeight > iCYMENU%, rcHeight, iCYMENU%)
        itemWidth& = (rc.Right - rc.Left)
        If Not pmd.bMainMenu Then
            itemWidth& = itemWidth& + (CXTEXTMARGIN * 2) + CXGAP + (m_iBitmapWidth% + CXBUTTONMARGIN) * 2
            itemWidth& = itemWidth& - (GetSystemMetrics(SM_CXMENUCHECK) - 1)
        End If
        lpms.itemWidth = itemWidth& + m_SideBitmapWidth
    End If
    Call CopyMemory(ByVal miPtr, lpms, Len(lpms))
    OnMeasureItem = True
End Function
Public Function GetMenuFont(hwnd As Long, Optional bForceReset As Boolean = False) As Long
    Dim WndObj                  As clsWndCoolMenu
    Dim sText                   As String
    Dim TextLen                 As Long
    Dim tLF                     As LogFont
    Dim tm                      As TEXTMETRIC
    Dim hWndDC                  As Long: hWndDC& = GetDC(hwnd&)
    Dim hdc                     As Long: hdc& = GetWindowDC(hwnd&)
    Set WndObj = WndCol(CStr(hwnd&))
    If (WndObj.MenuFont = 0) Or bForceReset Then
        If WndObj.FontName = "" Then
            sText$ = Space$(255)
            TextLen& = Len(sText$)
            TextLen& = GetTextFace(hWndDC&, TextLen&, sText$)
            WndObj.FontName = Left$(sText$, TextLen&)
            If WndObj.ForeColor = 0& Then WndObj.ForeColor = GetTextColor(hWndDC&)
            Call GetTextMetrics(hWndDC&, tm)
            Call ReleaseDC(hwnd&, hWndDC&)
            tLF.lfHeight = tm.tmHeight
            tLF.lfWeight = tm.tmWeight
        Else
            tLF.lfWeight = FW_NORMAL
            tLF.lfHeight = -MulDiv(WndObj.FontSize&, GetDeviceCaps(hdc&, LOGPIXELSY), 72)
            Call ReleaseDC(hwnd&, hdc&)
        End If
        tLF.lfFaceName = WndObj.FontName$ + Chr(0)
        WndObj.MenuFont& = CreateFontIndirect(tLF)
    End If
    GetMenuFont& = WndObj.MenuFont&
    Set WndObj = Nothing
End Function
Private Function GetMenuFontSep(hwnd As Long) As Long
    Dim WndObj                  As clsWndCoolMenu
    Dim tLF                     As LogFont
    Set WndObj = WndCol(CStr(hwnd&))
    If WndObj.MenuFontSep& = 0& Then
        tLF.lfFaceName = "Small Fonts" + Chr(0)
        tLF.lfHeight = 11
        tLF.lfWeight = FW_NORMAL
        WndObj.MenuFontSep& = CreateFontIndirect(tLF)
    End If
    GetMenuFontSep& = WndObj.MenuFontSep&
    Set WndObj = Nothing
End Function
Public Function Install(wndHandle As Long, Optional HelpObj As clsHelpCallBack) As Boolean
    Dim NewWnd                      As clsWndCoolMenu
    m_iBitmapWidth% = 16
    m_SideBitmapWidth = 0
    If wndHandle <> 0 Then
        If WndCol Is Nothing Then
            Set WndCol = New Collection
            Set pmds = New clsMyItemDatas
        End If
        Set NewWnd = New clsWndCoolMenu
        NewWnd.hwnd = wndHandle&
        NewWnd.PrevProc = GetWindowLong(wndHandle&, GWL_WNDPROC)
        NewWnd.SelectColor = GetSysColor(COLOR_HIGHLIGHT)
        Call SetWindowLong(wndHandle&, GWL_WNDPROC, AddressOf WindowProc)
        If Not (HelpObj Is Nothing) Then Set NewWnd.HelpObj = HelpObj
        NewWnd.SCMainMenu = True
        WndCol.Add NewWnd, CStr(wndHandle&)
        Set NewWnd = Nothing
        Call ConvertMenu(wndHandle&, GetMenu(wndHandle&), 0&, False, True, True)
    End If
    Install = True
End Function
Public Function Uninstall(wndHandle As Long) As Boolean
    If (wndHandle <> 0) And (Not (WndCol Is Nothing)) Then
        Call SetWindowLong(wndHandle&, GWL_WNDPROC, WndCol(CStr(wndHandle&)).PrevProc)
        WndCol.Remove CStr(wndHandle&)
        If WndCol.Count = 0 Then
            Set WndCol = Nothing
            Call DeleteObject(m_MarlettFont&)
            Call DeleteObject(m_bmpChecked&)
            Call DeleteObject(m_bmpRadioed)
            Set pmds = Nothing
        End If
        Uninstall = True
    End If
End Function
Private Sub FillRectEx(hdc As Long, rc As RECT, Color As Long)
    Dim hOldBrush               As Long
    Dim hNewBrush               As Long
    hNewBrush& = CreateSolidBrush(Color&)
    Call FillRect(hdc&, rc, hNewBrush&)
    Call DeleteObject(hNewBrush&)
End Sub
Private Function OffsetRect(InRect As RECT, ByVal xOffset As Long, ByVal yOffset As Long) As RECT
    OffsetRect.Left = InRect.Left + xOffset&
    OffsetRect.Right = InRect.Right + xOffset&
    OffsetRect.Top = InRect.Top + yOffset&
    OffsetRect.Bottom = InRect.Bottom + yOffset&
End Function
Private Sub OnMenuSelect(hwnd As Long, nItemID As Integer, nFlags As Integer, hSysMenu As Long)
    On Error GoTo ErrHandler
    Dim WndObj                  As clsWndCoolMenu: Set WndObj = WndCol(CStr(hwnd&))
    Dim info                    As MENUITEMINFO
    Dim i                       As Integer
    info.cbSize = LenB(info)
    info.fMask = MIIM_DATA Or MIIM_STATE Or MIIM_TYPE Or MIIM_ID
    Call GetMenuItemInfo(GetMenu(hwnd&), nItemID, MF_BYCOMMAND, info)
    If Not (WndObj.HelpObj Is Nothing) Then
        If (info.dwItemData <> 0&) And Not CBool(nFlags And MF_POPUP) Then
            Call WndObj.HelpObj.RaiseHelpEvent(pmds.Item(CStr(info.dwItemData)).sMenuText, pmds.Item(CStr(info.dwItemData)).sMenuHelp, Not CBool(info.fState And MFS_DISABLED))
        Else
            Call WndObj.HelpObj.RaiseHelpEvent("", "", True)
        End If
    End If
    If (hSysMenu = 0&) And (nFlags = &HFFFF) Then
        For i% = 0 To WndObj.CountMenuHeads
            Call ConvertMenu(hwnd&, WndObj.GetMenuHead(i%), 0&, False, False)
        Next
        WndObj.MainPopedIndex = -1
    End If
    Exit Sub
ErrHandler:
    Debug.Print Err.Number; Err.Description; " OnMenuSelect"
    Err.Clear
End Sub
Private Function CheckImage(Text As String) As Boolean
    On Error GoTo ErrClear
    Dim IPic                    As StdPicture
    Set IPic = LoadResPicture(PrepTextForImage(Text), vbResIcon)
    CheckImage = True
    Exit Function
ErrClear:
    Err.Clear
    CheckImage = False
End Function
Private Function PrepTextForImage(Text As String) As String
    Dim StText As String
    StText = Text
    If InStr(1, Text, " ", vbTextCompare) > 0 Then StText = Replace(StText, " ", "+")
    If InStr(1, Text, "@", vbTextCompare) > 0 Then StText = Replace(StText, "@", "AT")
    PrepTextForImage = UCase(StText)
End Function
Private Function GetButtonIndex(hwnd As Long, sMenuText As String) As ButType
    If CheckImage(sMenuText) = True Then
        GetButtonIndex.ButImage = 10
    Else
        GetButtonIndex.ButImage = -1
    End If
    GetButtonIndex.ButText = sMenuText
End Function
Private Function BSTRtoLPSTR(sBSTR As String, B() As Byte, lpsz As Long) As Long
    Dim cBytes                  As Long
    Dim sABSTR                  As String
    cBytes = LenB(sBSTR)
    ReDim B(1 To cBytes + 2) As Byte
    sABSTR = StrConv(sBSTR, vbFromUnicode)
    lpsz = StrPtr(sABSTR)
    CopyMemory B(1), ByVal lpsz, cBytes + 2