modcoolmenu.bas

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

    lpsz = VarPtr(B(1))
    BSTRtoLPSTR = cBytes
End Function
Private Sub DrawEmbossed(hdc As Long, pic As StdPicture, iButnIndex As Integer, rt As RECT, bInColor As Boolean)
    Dim rcImage                 As RECT
    Dim Mypic                   As StdPicture: Set Mypic = pic
    Dim cx                      As Integer
    Dim cy                      As Integer
    Dim hmemDC                  As Long
    Dim hBitmap                 As Long
    Dim hOldBitmap              As Long
    Dim hOldBackColor           As Long
    cx = Mypic.Width
    cy = Mypic.Height
    hmemDC& = CreateCompatibleDC(hdc&)
    If bInColor Then
        hBitmap& = CreateCompatibleBitmap(hdc&, cx%, cy%)
    Else
        hBitmap& = CreateBitmap(cx%, cy%, 1, 1, vbNull)
    End If
    hOldBitmap = SelectObject(hmemDC&, hBitmap&)
    Call PatBlt(hmemDC&, 0, 0, cx%, cy%, WHITENESS)
    Call DrawState(hmemDC&, 0&, 0&, Mypic.Handle, 0&, rt.Left, rt.Top, rt.Left + m_iBitmapWidth%, rt.Top + m_iBitmapWidth%, DST_ICON Or DSS_NORMAL)
    hOldBackColor& = SetBkColor(hdc&, RGB(255, 255, 255))
    Dim hbrShadow As Long, hbrHilite As Long
    hbrShadow& = CreateSolidBrush(GetSysColor(COLOR_BTNSHADOW))
    hbrHilite& = CreateSolidBrush(GetSysColor(COLOR_BTNHIGHLIGHT))
    Dim hOldBrush As Long
    hOldBrush& = SelectObject(hdc&, hbrHilite&)
    Call BitBlt(hdc&, rt.Left + 1, rt.Top + 1, cx%, cy%, hmemDC&, 0, 0, MAGICROP)
    Call SelectObject(hdc&, hbrShadow&)
    Call BitBlt(hdc&, rt.Left, rt.Top, cx%, cy%, hmemDC&, 0, 0, MAGICROP)
    Call SelectObject(hdc&, hOldBrush&)
    Call SetBkColor(hdc&, hOldBackColor&)
    Call SelectObject(hmemDC&, hOldBitmap&)
    Call DeleteObject(hOldBrush&)
    Call DeleteObject(hbrHilite&)
    Call DeleteObject(hbrShadow&)
    Call DeleteObject(hOldBackColor&)
    Call DeleteObject(hOldBitmap&)
    Call DeleteObject(hBitmap&)
    Call DeleteDC(hmemDC&)
End Sub

Private Function Draw3DMark(hwnd As Long, hdc As Long, rc As RECT, bCheck As Boolean, bSelected As Boolean, bDisabled As Boolean, hBmp As Long, bDrawCheck As Boolean) As Boolean
    On Error GoTo hError
    Dim WndObj                  As clsWndCoolMenu: Set WndObj = WndCol(CStr(hwnd&))
    Dim cx                      As Integer
    Dim cy                      As Integer
    Dim hmemDC                  As Long
    Dim hBmpTemp                As Long
    Dim hOldBmp                 As Long
    Dim hBrush                  As Long
    Dim lbInfo                  As LogBrush
    Dim hOldBrush               As Long
    Dim rcHighLigth             As RECT
    Dim X                       As Long: X = 0
    Dim Y                       As Long: Y = 0
    Dim hOldBackColor           As Long
    Dim i                       As Integer
    Dim BitArray(0 To 3)        As Long
    Dim hPat                    As Long
    Dim hPatBrush               As Long
    cx% = rc.Right - rc.Left
    cy% = rc.Bottom - rc.Top
    If Not CBool(hBmp) Then
        If WndObj.ComplexChecks Then
            hmemDC& = CreateCompatibleDC(hdc&)
            LSet rcHighLigth = rc
            rcHighLigth.Right = rcHighLigth.Right + 1
            rcHighLigth.Left = rcHighLigth.Left - 1
            Call FillRectEx(hdc&, rcHighLigth, IIf(bSelected And (Not bDisabled) And WndObj.FullSelect, WndObj.SelectColor&, GetSysColor(COLOR_MENU)))
            If m_bmpChecked = 0& Then
                m_bmpChecked& = LoadImage(0&, CLng(OBM_CHECKBOXES), IMAGE_BITMAP, 0&, 0&, LR_DEFAULTCOLOR)
                m_bmpRadioed& = LoadImage(0&, CLng(OBM_BTNCORNERS), IMAGE_BITMAP, 0&, 0&, LR_MONOCHROME)
            End If
            lbInfo.lbStyle = BS_HOLLOW
            hBrush& = CreateBrushIndirect(lbInfo)
            hOldBrush& = SelectObject(hdc&, hBrush&)
            If bCheck Then X = X + 13
            If bDisabled Then X = X + 26
            Y = 0
            hOldBackColor& = SetBkColor(hdc&, RGB(255, 255, 255))
            If bDrawCheck Then
                hOldBmp& = SelectObject(hmemDC&, m_bmpChecked&)
                Call BitBlt(hdc&, rc.Left + 3, rc.Top + 3, 13&, 13&, hmemDC&, X&, Y&, SRCCOPY)
            Else
            Y = 13
                hOldBmp& = SelectObject(hmemDC&, m_bmpRadioed&)
                Call BitBlt(hdc&, rc.Left + 3, rc.Top + 3, 13&, 13&, hmemDC&, 0&, 0&, MERGEPAINT)
                Call SelectObject(hmemDC&, m_bmpChecked&)
                Call BitBlt(hdc&, rc.Left + 3, rc.Top + 3, 13&, 13&, hmemDC&, X&, Y&, SRCAND)
            End If
            Call SetBkColor(hdc&, hOldBackColor&)
            Call SelectObject(hmemDC&, hOldBmp&)
            Call DeleteObject(hOldBmp&)
            Call SelectObject(hdc&, hOldBrush)
            Call DeleteObject(hBrush&)
            Call DeleteDC(hmemDC&)
        Else
            If bSelected Then
                Call FillRectEx(hdc&, rc, GetSysColor(COLOR_MENU))
            Else
                For i = 0 To 3
                    BitArray(i) = MakeLong(170, 85)
                Next
                hPat& = CreateBitmap(8&, 8&, 1&, 1&, BitArray(0))
                hPatBrush& = CreatePatternBrush(hPat&)
                hOldBrush& = SelectObject(hdc&, hPatBrush&)
                Call SetBkColor(hdc&, GetSysColor(COLOR_MENU))
                Call SetTextColor(hdc&, GetSysColor(COLOR_BTNHIGHLIGHT))
                Call PatBlt(hdc&, rc.Left, rc.Top, cx%, cy%, PATCOPY)
                Call SelectObject(hdc&, hOldBrush&)
                Call DeleteObject(hPatBrush&)
                Call DeleteObject(hOldBrush&)
            End If
            If bDisabled Then
                Call PrintGlyph(hdc&, IIf(bDrawCheck, "a", "h"), GetSysColor(COLOR_BTNHIGHLIGHT), OffsetRect(rc, 1, 1), DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
                Call PrintGlyph(hdc&, IIf(bDrawCheck, "a", "h"), GetSysColor(COLOR_GRAYTEXT), rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
            Else
                Call PrintGlyph(hdc&, IIf(bDrawCheck, "a", "h"), WndObj.ForeColor, rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
            End If
            Call DrawEdge(hdc&, rc, BDR_SUNKENOUTER, BF_RECT)
        End If
    Else
        'Bitmap argument is valid
    End If
    Draw3DMark = True
    Set WndObj = Nothing
    Exit Function
hError:
    Debug.Print Err.Number; Err.Description; " ( Draw3DMark )"
    Err.Clear
End Function
Private Function OnDrawMainMenu(hwnd As Long, lParam As Long, MousePosition As Long) As Long
    On Error GoTo NOPOP
    Dim hdc                     As Long
    Dim WndObj                  As clsWndCoolMenu: Set WndObj = WndCol(CStr(hwnd&))
    Dim hMenu                   As Long: hMenu& = GetMenu(hwnd&)
    Dim dwPapi                  As Double
    Dim Papi                    As POINTAPI
    Dim PopedIndex              As Long
    Dim info                    As MENUITEMINFO
    Dim MenuRect                As RECT
    Dim OldPopedRect            As RECT
    If WndObj.MainPopedIndex = -2 Then
        Set WndObj = Nothing
        Exit Function
    End If
    If MousePosition <> 5 And MousePosition > 0 Then GoTo NOPOP
    If MousePosition = 5 Then
        Set WndObj = Nothing
        Exit Function
    End If
    Papi.X = LoWord(lParam&)
    Papi.Y = HiWord(lParam&)
    Call CopyMemory(dwPapi, Papi, LenB(Papi))
    Dim MenuHitIndex As Long
    MenuHitIndex& = MenuItemFromPoint(hwnd&, hMenu&, dwPapi)
    If MenuHitIndex& = -1 Then GoTo NOPOP
    PopedIndex& = WndObj.MainPopedIndex
    If MenuHitIndex& = PopedIndex& Then
        Set WndObj = Nothing
        Exit Function
    End If
    info.cbSize = LenB(info)
    info.fMask = MIIM_TYPE
    Call GetMenuItemInfo(hMenu&, MenuHitIndex&, MF_BYPOSITION, info)
    If info.fType And (Not MFT_OWNERDRAW) Then GoTo NOPOP
    If PopedIndex& <> -1 Then GoSub DRAWFLAT
    Call GetMenuItemRect(hwnd&, hMenu&, MenuHitIndex&, MenuRect)
    WndObj.MainPopedIndex = MenuHitIndex&
    hdc& = GetDC(0&)
    Call DrawEdge(hdc&, MenuRect, BDR_RAISEDINNER, BF_RECT)
    Call ReleaseDC(hwnd&, hdc&)
    OnDrawMainMenu = True
    Set WndObj = Nothing
    Exit Function
NOPOP:
    If WndObj.MainPopedIndex > -1 Then
        GoSub DRAWFLAT
        WndObj.MainPopedIndex = -1
    End If
    Set WndObj = Nothing
    Exit Function
DRAWFLAT:
    Call GetMenuItemRect(hwnd&, hMenu&, CLng(WndObj.MainPopedIndex), OldPopedRect)
    hdc& = GetDC(0&)
    Call DrawEdge(hdc&, OldPopedRect, BDR_RAISEDINNER, BF_RECT Or BF_FLAT)
    Call ReleaseDC(hwnd&, hdc&)
    Return
End Function
Private Sub PrintGlyph(hdc As Long, Glyph As String, Color As Long, rt As RECT, ByVal wFormat As Long)
    Dim tLF                     As LogFont
    Dim hOldFont                As Long
    If m_MarlettFont& = 0& Then
        tLF.lfFaceName = "Marlett" + Chr(0)
        tLF.lfCharSet = SYMBOL_CHARSET
        tLF.lfHeight = 13
        m_MarlettFont& = CreateFontIndirect(tLF)
    End If
    Call SetBkMode(hdc&, TRANSPARENT)
    hOldFont& = SelectObject(hdc&, m_MarlettFont&)
    Call SetTextColor(hdc&, Color&)
    Call DrawText(hdc&, Glyph, 1, rt, wFormat&)
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error GoTo ErrorHandle
    Dim Result                  As Long
    Select Case Msg&
        Case WM_SETCURSOR
            Call OnDrawMainMenu(hwnd&, 0&, LoWord(lParam&))
        Case WM_NCHITTEST
            Call OnDrawMainMenu(hwnd&, lParam&, -1)
        Case WM_NCMOUSEMOVE
        Case WM_MEASUREITEM
            If OnMeasureItem(hwnd&, lParam&) Then
                WindowProc = True
                Exit Function
            End If
        Case WM_DRAWITEM
            If OnDrawItem(hwnd&, lParam&) Then
                WindowProc = True
                Exit Function
            End If
        Case WM_INITMENUPOPUP
            m_SideBitmapWidth = 0
            Call CallWindowProc(WndCol(CStr(hwnd&)).PrevProc, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)
            Call OnInitMenuPopup(hwnd&, wParam&, LoWord(lParam&), CBool(HiWord(lParam&)))
            WindowProc = 0&
            Exit Function
        Case WM_MENUCHAR
            Result = OnMenuChar(LoWord(wParam&), HiWord(wParam&), lParam&)
            If Result <> 0 Then
                WindowProc = Result
                Exit Function
            End If
        Case WM_MENUSELECT
            Call OnMenuSelect(hwnd&, LoWord(wParam&), HiWord(wParam&), lParam&)
        Case WM_WINDOWPOSCHANGED
            Dim OldH            As Long: OldH& = WndCol(CStr(hwnd&)).SCMainMenu
            If (OldH& <> 0&) And (OldH& <> -1&) And (GetMenu(hwnd&) <> OldH&) Then
                WndCol(CStr(hwnd&)).SCMainMenu = True
                Call ConvertMenu(hwnd&, GetMenu(hwnd&), 0&, False, True, True)
            End If
    End Select
Continue:
    WindowProc& = CallWindowProc(WndCol(CStr(hwnd&)).PrevProc, hwnd&, Msg&, wParam&, lParam&)
    Exit Function
ErrorHandle:
    'Debug.Print Err.Number; Err.Description; " WindowProc"
    Err.Clear
End Function
Private Function HiWord(LongIn As Long) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(LongIn) + 2, 2)
End Function
Private Function LoWord(LongIn As Long) As Integer
    Call CopyMemory(LoWord, LongIn, 2)
End Function
Private Function HiByte(WordIn As Integer) As Byte
    Call CopyMemory(HiByte, ByVal VarPtr(WordIn) + 1, 2)
End Function
Private Function LoByte(WordIn As Integer) As Byte
    Call CopyMemory(LoByte, WordIn, 2)
End Function
Private Function MakeLong(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeLong = CLng(LoWord)
    Call CopyMemory(ByVal VarPtr(MakeLong) + 2, HiWord, 2)
End Function
Private Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
    MakeWord = CInt(LoByte)
    Call CopyMemory(ByVal VarPtr(MakeWord) + 1, HiByte, 1)
End Function
Public Function ColorEmbossed(hwnd As Long, Optional Value As Variant) As Boolean
    On Error Resume Next
    If IsMissing(Value) Then
        ColorEmbossed = WndCol(CStr(hwnd&)).ColorEmbossed
    Else
        WndCol(CStr(hwnd&)).ColorEmbossed = Value
        ColorEmbossed = Value
    End If
End Function
Public Function ComplexChecks(hwnd As Long, Optional Value As Variant) As Boolean
    On Error Resume Next
    If IsMissing(Value) Then
        ComplexChecks = WndCol(CStr(hwnd&)).ComplexChecks
    Else
        WndCol(CStr(hwnd&)).ComplexChecks = Value
        ComplexChecks = Value
    End If
  
End Function
Public Function SelectColor(hwnd As Long, Optional Value As Variant) As Long
    On Error Resume Next
    If IsMissing(Value) Then
        SelectColor = WndCol(CStr(hwnd&)).SelectColor
    Else
        WndCol(CStr(hwnd&)).SelectColor = Value
        SelectColor = Value
    End If
End Function
Public Function RightTo