ctxhookmenu.ctl

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

VERSION 5.00
Begin VB.UserControl ctxHookMenu 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   2880
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3840
   ClipBehavior    =   0  '无
   InvisibleAtRuntime=   -1  'True
   PropertyPages   =   "ctxHookMenu.ctx":0000
   ScaleHeight     =   2880
   ScaleWidth      =   3840
   ToolboxBitmap   =   "ctxHookMenu.ctx":0020
   Begin VB.Image Image1 
      Height          =   480
      Left            =   0
      Picture         =   "ctxHookMenu.ctx":0332
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "ctxHookMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'==============================================================================
' ctxHookMenu.ctl
'
'   Subclassing Thunk (SuperClass V2) Project Samples
'   Copyright (c) 2002 by Vlad Vissoultchev <[e-mail]>
'
'   Office XP menus control
'
' Modifications:
'
' 2002-10-28    WQW     Initial implementation
' 2002-11-10    WQW     Major refactoring for NT 4.0 compatibility
'
'==============================================================================
Option Explicit
Implements ISubclassingSink
Private Const MODULE_NAME As String = "ctxHookMenu"

#Const WEAK_REF_CURRENTMENU = 1
#Const WEAK_REF_ME = 0 '--- don't turn it on - its GPF-ing!!!

'==============================================================================
' API
'==============================================================================

'--- window messages
Private Const WM_DESTROY                As Long = &H2
Private Const WM_ERASEBKGND             As Long = &H14
Private Const WM_SYSCOLORCHANGE         As Long = &H15
Private Const WM_SHOWWINDOW             As Long = &H18
Private Const WM_DRAWITEM               As Long = &H2B
Private Const WM_MEASUREITEM            As Long = &H2C
Private Const WM_WINDOWPOSCHANGING      As Long = &H46
Private Const WM_NCDESTROY              As Long = &H82
Private Const WM_NCCALCSIZE             As Long = &H83
Private Const WM_NCPAINT                As Long = &H85
Private Const WM_INITMENUPOPUP          As Long = &H117
Private Const WM_MENUSELECT             As Long = &H11F
Private Const WM_ENTERMENULOOP          As Long = &H211
Private Const WM_EXITMENULOOP           As Long = &H212
Private Const WM_MDISETMENU             As Long = &H230
Private Const WM_MDIGETACTIVE           As Long = &H229
Private Const WM_PRINT                  As Long = &H317
Private Const WM_PRINTCLIENT            As Long = &H318
'--- menu flag
Private Const MF_GRAYED                 As Long = &H1
Private Const MF_DISABLED               As Long = &H2
Private Const MF_CHECKED                As Long = &H8
Private Const MF_POPUP                  As Long = &H10
Private Const MF_HILITE                 As Long = &H80&
Private Const MF_SYSMENU                As Long = &H2000
Private Const MF_BYCOMMAND              As Long = &H0&
Private Const MF_BYPOSITION             As Long = &H400&
'--- menu item info mask
Private Const MIIM_ID                   As Long = &H2
Private Const MIIM_SUBMENU              As Long = &H4
Private Const MIIM_TYPE                 As Long = &H10
Private Const MIIM_DATA                 As Long = &H20
'#if(WINVER >= 0x0500)
    Private Const MIIM_STRING           As Long = &H40
    Private Const MIIM_BITMAP           As Long = &H80
    Private Const MIIM_FTYPE            As Long = &H100
'#endif /* WINVER >= 0x0500 */
'--- menu item info type
Private Const MFT_STRING                As Long = 0
Private Const MFT_OWNERDRAW             As Long = &H100
Private Const MFT_SEPARATOR             As Long = &H800
Private Const MFT_RIGHTJUSTIFY          As Long = &H4000
'--- for ownerdrawn items
Private Const ODT_MENU                  As Long = 1
Private Const ODS_SELECTED              As Long = &H1
Private Const ODS_HOTLIGHT              As Long = &H40
Private Const ODA_SELECT                As Long = &H2
'--- for GetSystemMetrics
Private Const SM_CYSCREEN               As Long = 1
Private Const SM_CXDLGFRAME             As Long = 7
Private Const SM_CXFRAME                As Long = 32
Private Const SM_CXEDGE                 As Long = 45
'--- for SetWindowLong (window styles)
Private Const WS_BORDER                 As Long = &H800000
Private Const WS_VISIBLE                As Long = &H10000000
Private Const WS_EX_DLGMODALFRAME       As Long = &H1&
Private Const WS_EX_WINDOWEDGE          As Long = &H100
'--- for GetClassLong
Private Const GCL_STYLE                 As Long = (-26)
Private Const CS_DROPSHADOW             As Long = &H20000
'--- for SetWindowPos
Private Const SWP_NOSIZE                As Long = &H1
Private Const SWP_NOMOVE                As Long = &H2
Private Const SWP_NOZORDER              As Long = &H4
Private Const SWP_NOACTIVATE            As Long = &H10
Private Const SWP_DRAWFRAME             As Long = &H20
Private Const SWP_FLAGS                 As Long = SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_DRAWFRAME
'--- for SystemParametersInfo
Private Const SPI_GETHIGHCONTRAST       As Long = 66
Private Const SPI_GETFLATMENU           As Long = &H1022
'--- for HIGHCONTRAST struct
Private Const HCF_HIGHCONTRASTON        As Long = &H1
Private Const HCF_AVAILABLE             As Long = &H2
'--- for GetDeviceCaps
Private Const BITSPIXEL                 As Long = 12
Private Const PLANES                    As Long = 14
'--- for registry
Private Const HKEY_CURRENT_USER         As Long = &H80000001
Private Const KEY_QUERY_VALUE           As Long = &H1
'--- for GetSysColor
Private Const COLOR_MENUBAR             As Long = 30
'--- for GetVersionEx
Private Const VER_PLATFORM_WIN32_NT     As Long = 2

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal uItem As Long, lprcItem As RECT) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetViewportOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal lpPoint As Long) As Long
Private Declare Function SetViewportOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, ByVal lpPoint As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function ExcludeClipRect Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hrgn As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Type ICONINFO
    fIcon               As Long
    xHotspot            As Long
    yHotspot            As Long
    hbmMask             As Long
    hbmColor            As Long
End Type

Private Type MENUITEMINFO
    cbSize              As Long
    fMask               As Long
    fType               As Long
    fState              As Long
    wID                 As Long
    hSubMenu            As Long
    hbmpChecked         As Long
    hbmpUnchecked       As Long
    dwItemData          As Long
    dwTypeData          As Long
    cch                 As Long
    hbmpItem            As Long
End Type

Private Type MEASUREITEMSTRUCT
    CtlType             As Long
    CtlID               As Long
    itemID              As Long
    itemWidth           As Long
    itemHeight          As Long
    itemData            As Long
End Type

Private Type DRAWITEMSTRUCT
    CtlType             As Long
    CtlID               As Long
    itemID              As Long
    itemAction          As Long
    itemState           As Long
    hwndItem            As Long
    hDC                 As Long
    rcItem              As RECT
    itemData            As Long
End Type

Private Type WINDOWPOS
    hwnd                As Long
    hWndInsertAfter     As Long
    X                   As Long
    Y                   As Long
    cx                  As Long
    cy                  As Long
    Flags               As Long
End Type

Private Type UcsRgbQuad
    R                   As Byte
    G                   As Byte
    b                   As Byte
    A                   As Byte
End Type

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128      '  Maintenance string for PSS usage
End Type

Private Type HIGHCONTRAST
    cbSize              As Long
    dwFlags             As Long
    lpszDefaultScheme   As Long
End Type


'==============================================================================
' Constants and member vars
'==============================================================================

Private Const MASK_COLOR            As Long = &HFF00FF
Private Const DEF_SELECTDISABLED    As Boolean = True
Private Const DEF_BITMAPSIZE        As Long = 16
Private Const DEF_USESYSTEMFONT     As Boolean = True
Private Const STR_CLIENT_CLASS      As String = "MDIClient"
Private Const SEPARATOR_HEIGHT      As Long = 2

Private m_oSubclass             As cSubclassingThunk
Private m_oClientSubclass       As cSubclassingThunk
Private m_cMenuSubclass         As Collection
Private m_cMemDC                As Collection
Private m_cBmps                 As Collection
Private m_ptLast                As POINTAPI
Private m_hFormMenu             As Long
Private m_hFormHwnd             As Long
Private m_hParentHwnd           As Long
Private m_lEdgeWidth            As Long '--- usually 2 px
Private m_lFrameWidth           As Long '--- usually 3 px
Private m_clrSelMenuBorder      As OLE_COLOR
Private m_clrSelMenuBack        As OLE_COLOR
Private m_clrSelMenuFore        As OLE_COLOR
Private m_clrSelCheckBack       As OLE_COLOR
Private m_clrMenuBorder         As OLE_COLOR
Private m_clrMenuBack           As OLE_COLOR
Private m_clrMenuFore           As OLE_COLOR
Private m_clrCheckBack          As OLE_COLOR
Private m_clrCheckFore          As OLE_COLOR
Private m_clrDisabledMenuBorder As OLE_COLOR
Private m_clrDisabledMenuBack   As OLE_COLOR
Private m_clrDisabledMenuFore   As OLE_COLOR
Private m_clrMenuBarBack        As OLE_COLOR
Private m_clrMenuPopupBack      As OLE_COLOR
Private m_lMenuHeight           As Long
Private m_lTextHeight           As Long
Private m_hLastMenu             As Long
Private m_bSelectDisabled       As Boolean
Private m_lBitmapSize           As Long
Private WithEvents m_oFont      As StdFont
Attribute m_oFont.VB_VarHelpID = -1
Private m_bUseSystemFont        As Boolean
Private m_cMenuInfo             As Collection
Private m_lInitMenuMsg          As Long
Private m_bExpectingPopup       As Boolean
Private m_bConstrainedColors    As Boolean
Private m_hLastSelMenu          As Long