modsubclasser.bas

AeroSuite--一组非常漂亮的VISTA控件集

Attribute VB_Name = "modSubClasser"
Option Explicit
' APIs used in this module
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function GetGDIObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

' used to convert VB system color variables to proper long color values
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
' used to create drawing pens/lines & DC movements
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long


' temporary - all border routines will be moved to a separate class
Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function OffsetRgn Lib "gdi32.dll" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32.dll" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32.dll" () As Long

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Public Enum ButtonStateConstants
    bsNormal = 0
    bsHover = 1
    bsDown = 2
    bsDisabled = 3
End Enum
Public Enum TitlelBarBtnPosition
    tbPosDefault = 0
    tbPosLockX = 1
    tbPosLockY = 2
    tbPosStatic = 4
    tbNoFrame = 128
End Enum
Public Enum SysMenuItemConstants
    smClose = 2
    smMinimize = 4
    smMaximize = 8
    smSize = 16
    smMove = 32
    smSysIcon = 64
End Enum
Public Enum WindowBorderStyleConstants
    wbBlackEdge = 1
    wbThin = 2
    wbDialog = 3
    wbThick = 4
    wbCustom = 5
End Enum
Public Enum FontStateColorConstants
    fcEnabled = 0
    fcSelected = 1
    fcDisabled = 2
    fcInActive = 3
End Enum
Public Type SystemMenuItems
    ID As Long
    SysIcon As Long
    ItemType As Long
    Caption As String
End Type
Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
Private Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Const MSGF_MENU As Long = 2
Private Const WH_KEYBOARD As Long = 2
Private Const WH_MSGFILTER As Long = -1
Private Const WH_GETMESSAGE As Long = 3
Private Const WH_MOUSE As Long = 7

Private menuHK_ptr As Long
Private oldMenuHook As Long
Private inputHK_ptr As Long
Private oldKeyBdHook As Long
Private oldMouseHook As Long

Public Sub SetMenuHook(bSet As Boolean, callingClass As clsMenuBarControl)

If oldMenuHook Then UnhookWindowsHookEx oldMenuHook
If bSet Then
    Dim hookAddr As Long
    hookAddr = ReturnAddressOf(AddressOf MenuFilterProc)
    menuHK_ptr = ObjPtr(callingClass)
    oldMenuHook = SetWindowsHookEx(WH_MSGFILTER, hookAddr, 0, GetCurrentThreadId())
Else
    oldMenuHook = 0
    menuHK_ptr = 0
End If
End Sub

Public Sub SetInputHook(bSet As Boolean, callingClass As clsMenuBarControl)

If oldKeyBdHook Then ' currently existing hook; remove it
    UnhookWindowsHookEx oldKeyBdHook
    UnhookWindowsHookEx oldMouseHook
End If
If bSet Then
    Dim hookAddr As Long
    hookAddr = ReturnAddressOf(AddressOf KeybdFilterProc)
    inputHK_ptr = ObjPtr(callingClass)
    oldKeyBdHook = SetWindowsHookEx(WH_KEYBOARD, hookAddr, 0, GetCurrentThreadId())
    hookAddr = ReturnAddressOf(AddressOf MouseFilterProc)
    oldMouseHook = SetWindowsHookEx(WH_MOUSE, hookAddr, 0, GetCurrentThreadId())
Else
    oldKeyBdHook = 0
    oldMouseHook = 0
    inputHK_ptr = 0
End If
End Sub

Public Function GetSubClassAddr() As Long
GetSubClassAddr = ReturnAddressOf(AddressOf NewWndProc)
End Function

Private Function ReturnAddressOf(lAddress As Long) As Long
ReturnAddressOf = lAddress
End Function

Private Function NewWndProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim tgtClass As clsFrameControl
If GetObjectFromPointer(GetProp(hWnd, "lvCFrame_Optr"), tgtClass) Then
    NewWndProc = tgtClass.NewWndProc(wMsg, wParam, lParam)
End If
End Function

Private Function MenuFilterProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If ncode = MSGF_MENU Then
    Dim tgtClass As clsMenuBarControl
    If GetObjectFromPointer(menuHK_ptr, tgtClass) Then
        If tgtClass.SetMenuAction(lParam) = True Then
            MenuFilterProc = 1
            Exit Function
        End If
    End If
End If
MenuFilterProc = CallNextHookEx(oldMenuHook, ncode, wParam, lParam)
End Function

Private Function MouseFilterProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If ncode > -1 Then
    Dim tgtClass As clsMenuBarControl
    If GetObjectFromPointer(inputHK_ptr, tgtClass) Then
        'If tgtClass.SetMessageAction(wParam, lParam) = True Then
        If tgtClass.SetMouseAction(wParam, lParam) = True Then
            MouseFilterProc = 1
            Exit Function
        End If
    End If
End If
MouseFilterProc = CallNextHookEx(oldMouseHook, ncode, wParam, lParam)
End Function

Private Function KeybdFilterProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If ncode > -1 Then
    Dim tgtClass As clsMenuBarControl
    If GetObjectFromPointer(inputHK_ptr, tgtClass) Then
        If tgtClass.SetKeyBdAction(wParam, lParam) = True Then
            KeybdFilterProc = 1
            Exit Function
        End If
    End If
End If
KeybdFilterProc = CallNextHookEx(oldKeyBdHook, ncode, wParam, lParam)
End Function

Public Function GetObjectFromPointer(oPtr As Long, outClass As Object) As Boolean
If oPtr Then
    Dim tgtClass As Object
    CopyMemory tgtClass, oPtr, &H4
    Set outClass = tgtClass
    CopyMemory tgtClass, 0&, &H4
    GetObjectFromPointer = True
End If
End Function

Public Function LoWord(DWord As Long) As Long
' =====================================================================
' function to return the LoWord of a Long value
' =====================================================================
     If DWord And &H8000& Then
        LoWord = DWord Or &HFFFF0000
     Else