modcoolmenu.bas

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

  tmAscent                      As Long
  tmDescent                     As Long
  tmInternalLeading             As Long
  tmExternalLeading             As Long
  tmAveCharWidth                As Long
  tmMaxCharWidth                As Long
  tmWeight                      As Long
  tmOverhang                    As Long
  tmDigitizedAspectX            As Long
  tmDigitizedAspectY            As Long
  tmFirstChar                   As Byte
  tmLastChar                    As Byte
  tmDefaultChar                 As Byte
  tmBreakChar                   As Byte
  tmItalic                      As Byte
  tmUnderlined                  As Byte
  tmStruckOut                   As Byte
  tmPitchAndFamily              As Byte
  tmCharSet                     As Byte
End Type

Private Type IMAGEINFO
  hbmImage                      As Long
  hbmMask                       As Long
  Unused1                       As Long
  Unused2                       As Long
  rcImage                       As RECT
End Type

Private Type ButType
    ButText                     As String
    ButImage                    As Integer
End Type

Private m_bmpChecked            As Long
Private m_bmpRadioed            As Long

Private m_MarlettFont           As Long
Private m_iBitmapWidth          As Integer
Private m_SideBitmapWidth       As Long

Private pmds                    As clsMyItemDatas
Private WndCol                  As Collection

'删除字符串中的空格
Public Function Remove_Spaces(ByVal strString As String) As String
    Dim strResult As String
    strResult = ""
    Dim intIndex As Integer
    
    For intIndex = 1 To Len(strString)
        If (Mid$(strString, intIndex, 1) <> " ") Then
            If Asc(Mid$(strString, intIndex, 1)) <> 0 Then
              strResult = strResult + Mid$(strString, intIndex, 1)
            End If
        End If
    Next intIndex
    Remove_Spaces = strResult
End Function

Private Sub ConvertMenu(hwnd As Long, hMenu As Long, nIndex As Long, bSysMenu As Boolean, bShowButtons As Boolean, Optional Permanent As Boolean = False)
    On Error GoTo ErrorHandle
    Dim i                           As Long
    Dim k                           As Byte
    Dim info                        As MENUITEMINFO
    Dim TmpMenuInfo                 As ButType
    Dim dwItemData                  As Long
    Dim pmd                         As clsMyItemData
    Dim Text                        As String
    Dim ByteBuffer()                As Byte
    Dim nItem                       As Long
    nItem& = GetMenuItemCount(hMenu&)
    If nItem& = -1 Then Exit Sub
    For i& = 0 To nItem& - 1
        ReDim ByteBuffer(0 To 200) As Byte
        For k = 0 To 200
            ByteBuffer(k) = 0
        Next k
        info.fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE Or MIIM_SUBMENU
        info.dwTypeData = VarPtr(ByteBuffer(0))
        info.cch = UBound(ByteBuffer)
        info.cbSize = LenB(info)
        Call GetMenuItemInfo(hMenu&, i&, MF_BYPOSITION, info)
        dwItemData& = info.dwItemData
        If bSysMenu And (info.wID >= &HF000) Then GoTo NextGoto
        info.fMask = 0& 'reset mask value
        If bShowButtons Then
            If Not CBool(info.fType And MFT_OWNERDRAW) Then
                info.fType = info.fType Or MFT_OWNERDRAW
                info.fMask = info.fMask Or MIIM_TYPE
                If dwItemData& = 0& Then
                    info.dwItemData = CLng(pmds.Count + 1)
                    info.fMask = info.fMask Or MIIM_DATA
                    Set pmd = pmds.Add(CStr(info.dwItemData))
                    Text$ = Left(StrConv(ByteBuffer, vbUnicode), info.cch)
                    'Debug.Print Text$    'Remove_Spaces(
                    pmd.sMenuText = Text$
                    Dim iBreakPos As Integer
                    iBreakPos% = InStr(Text$, "|")
                    If iBreakPos% Then
                        Dim iBreak2Pos As Integer
                        Text$ = Remove_Spaces(Text$)
                        iBreak2Pos% = InStr(Right(Text$, Len(Text$) - iBreakPos%), "|")
                        Dim HelpText As String
                        Dim iHelpLen As Integer
                        HelpText$ = Mid(Text$, iBreakPos% + 1, iBreak2Pos% - 1)
                        iHelpLen% = Len(HelpText$)
                        pmd.sMenuHelp = HelpText$
                        pmd.sMenuText = Right(Text$, Len(Text$) - (iBreakPos% + iBreak2Pos%))
                    Else
                        pmd.sMenuText = Text$

                    End If
                    Dim cFirstChar As String * 3
                    cFirstChar$ = Left(Text$, 3)
                    Dim iCount As Boolean
                    iCount = False
                    If cFirstChar$ = "(-)" Then
                        iCount = True
                        info.fType = info.fType Or &H800
                        If pmd.sMenuHelp = "" Then pmd.sMenuText = Right(Text$, Len(Text$) - 3)
                    ElseIf cFirstChar$ = "(=)" Then
                        info.fType = info.fType Or &H40
                        If pmd.sMenuHelp = "" Then pmd.sMenuText = Right(Text$, Len(Text$) - 3)
                    ElseIf cFirstChar$ = "(+)" Then
                        info.fType = info.fType Or &H40 Or &H800
                        If pmd.sMenuHelp = "" Then pmd.sMenuText = Right(Text$, Len(Text$) - 3)
                    End If
                    pmd.bAsMark = (cFirstChar$ = "(*)") Or (cFirstChar$ = "(#)")
                    If pmd.bAsMark Then
                        pmd.bAsCheck = (cFirstChar$ = "(#)")
                        If pmd.sMenuHelp = "" Then pmd.sMenuText = Right(Text$, Len(Text$) - 3)
                    End If
                    TmpMenuInfo = GetButtonIndex(hwnd&, pmd.sMenuText)
                    pmd.iButton = TmpMenuInfo.ButImage
                    pmd.sMenuText = TmpMenuInfo.ButText
                    Debug.Print pmd.sMenuText
                    pmd.fType = info.fType
                    pmd.bTrueSub = (info.hSubMenu <> 0&) And (Not Permanent)
                Else
                    Set pmd = pmds.Item(CStr(dwItemData&))
                End If
                pmd.bMainMenu = Permanent
            End If
            If Not Permanent Then Call WndCol(CStr(hwnd&)).AddMenuHead(hMenu)
        Else
            If info.fType And MFT_OWNERDRAW Then
                info.fType = info.fType And (Not MFT_OWNERDRAW)
                info.fMask = info.fMask Or MIIM_TYPE
                Set pmd = pmds.Item(CStr(dwItemData&))
                Dim cLeadChar As String
                cLeadChar$ = ""
                If pmd.bAsMark Then
                If pmd.bAsCheck Then
                    cLeadChar = "(#)"
                Else
                    cLeadChar = "(*)"
                End If
            End If
            If pmd.fType And &H800 Then
                cLeadChar$ = "(-)"
                info.fType = info.fType And (Not &H800)
            End If
            If pmd.fType And &H40 Then
                cLeadChar$ = "(=)"
                info.fType = info.fType And (Not &H40)
            End If
            If pmd.sMenuHelp <> "" Then _
                pmd.sMenuHelp = "|" + pmd.sMenuHelp + "|"
                Text$ = cLeadChar$ + pmd.sMenuHelp + pmd.sMenuText
                info.cch = BSTRtoLPSTR(Text$, ByteBuffer, info.dwTypeData)
            End If
            If dwItemData <> 0& Then
                info.dwItemData = 0&
                info.fMask = info.fMask Or MIIM_DATA
                pmds.Remove CStr(dwItemData&) 'by key
            End If
        End If
        If info.fMask Then Call SetMenuItemInfo(hMenu&, i&, MF_BYPOSITION, info)
NextGoto:
    Next i&
    Exit Sub
ErrorHandle:
  Debug.Print Err.Number; Err.Description; " ConvertMenu"
  Err.Clear
End Sub
Private Sub OnInitMenuPopup(hwnd As Long, hMenu As Long, nIndex As Long, bSysMenu As Boolean)
    WndCol(CStr(hwnd&)).MainPopedIndex = -2 ' Deselect main menu item
    Call ConvertMenu(hwnd&, hMenu&, nIndex&, bSysMenu, True, False)
End Sub
Private Function OnMenuChar(nChar As Long, nFlags As Long, hMenu As Long) As Long
    Dim i                       As Long
    Dim nItem                   As Long
    Dim dwItemData              As Long
    Dim info                    As MENUITEMINFO
    Dim Count                   As Integer: Count% = 0
    Dim iCurrent                As Integer
    Dim Text                    As String
    Dim iAmpersand              As Integer
    Dim bMainMenu               As Boolean
    Dim iSelect                 As Integer
    
    ReDim ItemMatch(0 To 0) As Integer
    nItem& = GetMenuItemCount(hMenu&)
    For i& = 0 To nItem& - 1
        info.cbSize = LenB(info)
        info.fMask = MIIM_DATA Or MIIM_TYPE Or MIIM_STATE
        Call GetMenuItemInfo(hMenu&, i&, MF_BYPOSITION, info)
        dwItemData& = info.dwItemData
        If (info.fType And MFT_OWNERDRAW) And dwItemData& <> 0 Then
            Text$ = pmds(CStr(dwItemData&)).sMenuText
            iAmpersand% = InStr(Text$, "&")
            If (iAmpersand% > 0) And (UCase(Chr(nChar&)) = UCase(Mid(Text$, iAmpersand% + 1, 1))) Then
                If Count > UBound(ItemMatch) Then ReDim Preserve ItemMatch(0 To Count%)
                ItemMatch(Count%) = i&
                Count% = Count% + 1
            End If
        End If
        If info.fState And MFS_HILITE Then iCurrent% = i&
    Next i&
    Count% = Count% - 1
    If Count% = -1 Then
        OnMenuChar = 0&
        Exit Function
    End If
    bMainMenu = pmds(CStr(dwItemData&)).bMainMenu
    If Count% = 0 Then
        OnMenuChar = MakeLong(ItemMatch(0), MNC_EXECUTE)
        Exit Function
    End If
    For i& = 0 To Count%
        If ItemMatch(i&) = iCurrent% Then
            iSelect% = i&
            Exit For
        End If
    Next i&
    OnMenuChar = MakeLong(ItemMatch(iSelect%), MNC_SELECT)
End Function
Private Sub DrawMenuText(hwnd As Long, hdc As Long, rc As RECT, Text As String, Color As Long, Optional bLeftAlign As Boolean = True, Optional bRightToLeft As Boolean = False)
    Dim LeftStr                 As String
    Dim RightStr                As String
    Dim iTabPos                 As Integer
    Dim OldFont                 As Long
    LeftStr$ = Text$
    iTabPos = InStr(LeftStr$, Chr(9))
    If iTabPos > 0 Then
        RightStr$ = Right$(LeftStr$, Len(LeftStr$) - iTabPos)
        LeftStr$ = Left$(LeftStr$, iTabPos - 1)
    End If
    Call SetTextColor(hdc&, Color&)
    OldFont& = SelectObject(hdc&, GetMenuFont(hwnd&))
    Call DrawText(hdc&, LeftStr$, Len(LeftStr$), rc, IIf(bLeftAlign, IIf(bRightToLeft, DT_RIGHT, DT_LEFT), DT_CENTER) Or DT_VCENTER Or DT_SINGLELINE)
    If iTabPos > 0 Then Call DrawText(hdc&, RightStr$, Len(RightStr$), rc, IIf(bRightToLeft, DT_LEFT, DT_RIGHT) Or DT_VCENTER Or DT_SINGLELINE)
    Call SelectObject(hdc&, OldFont&)
End Sub
Private Function OnDrawItem(hwnd As Long, ByRef dsPtr As Long, Optional bOverMain As Boolean = False) As Boolean
    On Error GoTo ErrHandler
    Dim lpds                    As DRAWITEMSTRUCT
    Call CopyMemory(lpds, ByVal dsPtr&, Len(lpds))
    Dim rt                      As RECT
    Dim rtItem                  As RECT
    Dim rtText                  As RECT
    Dim rtButn                  As RECT
    Dim rtIcon                  As RECT
    Dim rtHighlight             As RECT
    Dim OldFont                 As Long
    Dim hIcon                   As Long
    Dim pic                     As StdPicture
    Dim dwItemData              As Long
    Dim hdc                     As Long
    Dim WndObj                  As clsWndCoolMenu: Set WndObj = WndCol(CStr(hwnd&))
    Dim pmd                     As clsMyItemData
    Dim SepMargin               As Integer
    Dim bDisabled               As Boolean
    Dim bSelected               As Boolean
    Dim bChecked                As Boolean
    Dim bHaveButn               As Boolean
    Dim iButton                 As Integer
    Dim info                    As MENUITEMINFO
    Dim iButnWidth              As Integer
    Dim dwColorBG               As Long
    Dim dwSelTextColor          As Long
    Dim dwColorText             As Long
    Dim TextOffset              As Integer
    Dim rtArrow                 As RECT
    dwItemData& = lpds.ItemData
    If (dwItemData& = 0&) Or (lpds.CtlType <> ODT_MENU) Or (dwItemData& > pmds.Count) Then
        OnDrawItem = False
        Exit Function
    End If
    hdc& = lpds.hdc
    LSet rtItem = lpds.rcItem
    Set pmd = pmds.Item(CStr(dwItemData&))
    
    If pmd.fType And MFT_SEPARATOR Then
        LSet rt = rtItem
        LSet rtText = rtItem
        SepMargin = 15
        rt.Left = rt.Left + SepMargin
        rt.Right = rt.Right - SepMargin
        rt.Top = rt.Top + ((rt.Bottom - rt.Top) \ 2) - 1
        Call DrawEdge(hdc&, rt, EDGE_ETCHED, BF_TOP)
        If pmd.sMenuText <> "" Then
            OldFont& = SelectObject(hdc&, GetMenuFontSep(hwnd&))
            rtText = OffsetRect(rtText, 1, 1)