Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing QuickQuery HL Edition/mCoolMenu.bas (66.52 KB)
Attribute VB_Name = "mCoolMenu"
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) 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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreateHatchBrush Lib "gdi32" (ByVal nIndex As Long, ByVal crColor As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hDC As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal fuFlags As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) 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 FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex 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 uItem As Long, ByVal ByPosition As Long, ByRef lpMenuItemInfo As MENUITEMINFO) As Boolean
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 GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd 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 GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hinst As Long, ByVal lpszName As Any, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
Private Declare Function MenuItemFromPoint Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long, ByVal ptScreen As Double) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) 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 SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor 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 ImageList_GetIcon Lib "comctl32" (ByVal himl As Long, ByVal i As Long, ByVal diIgnore As Long) As Long
Private Declare Function ImageList_Draw Lib "comctl32" (ByVal himl As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, ByVal fStyle As Long) As Long
Private Declare Function ImageList_GetImageInfo Lib "comctl32" (ByVal himl As Long, ByVal i As Long, IMAGEINFO As Any) As Long
'Used by CreateBrushIndirect
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
'LOGBRUSH constants
Private Const BS_SOLID = 0
Private Const BS_NULL = 1
Private Const BS_HOLLOW = BS_NULL
Private Const BS_HATCHED = 2
Private Const BS_PATTERN = 3
Private Const BS_INDEXED = 4
Private Const BS_DIBPATTERN = 5
Private Const BS_DIBPATTERNPT = 6
Private Const BS_PATTERN8X8 = 7
Private Const BS_DIBPATTERN8X8 = 8
'LoadImage constants
Private Const IMAGE_BITMAP = 0&
Private Const IMAGE_ICON = 1&
Private Const IMAGE_CURSOR = 2&
'LoadImage constants
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_CREATEDIBSECTION = &H2000
Private Const LR_COPYFROMRESOURCE = &H4000
Private Const LR_SHARED = &H8000
'LoadImage constants
Private Const OBM_LFARROWI = 32734
Private Const OBM_RGARROWI = 32735
Private Const OBM_DNARROWI = 32736
Private Const OBM_UPARROWI = 32737
Private Const OBM_COMBO = 32738
Private Const OBM_MNARROW = 32739
Private Const OBM_LFARROWD = 32740
Private Const OBM_RGARROWD = 32741
Private Const OBM_DNARROWD = 32742
Private Const OBM_UPARROWD = 32743
Private Const OBM_RESTORED = 32744
Private Const OBM_ZOOMD = 32745
Private Const OBM_REDUCED = 32746
Private Const OBM_RESTORE = 32747
Private Const OBM_ZOOM = 32748
Private Const OBM_REDUCE = 32749
Private Const OBM_LFARROW = 32750
Private Const OBM_RGARROW = 32751
Private Const OBM_DNARROW = 32752
Private Const OBM_UPARROW = 32753
Private Const OBM_CLOSE = 32754
Private Const OBM_OLD_RESTORE = 32755
Private Const OBM_OLD_ZOOM = 32756
Private Const OBM_OLD_REDUCE = 32757
Private Const OBM_BTNCORNERS = 32758
Private Const OBM_CHECKBOXES = 32759
Private Const OBM_CHECK = 32760
Private Const OBM_BTSIZE = 32761
Private Const OBM_OLD_LFARROW = 32762
Private Const OBM_OLD_RGARROW = 32763
Private Const OBM_OLD_DNARROW = 32764
Private Const OBM_OLD_UPARROW = 32765
Private Const OBM_SIZE = 32766
Private Const OBM_OLD_CLOSE = 32767
' GetSystemMetrics() constants
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CYCAPTION = 4
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYVTHUMB = 9
Private Const SM_CXHTHUMB = 10
Private Const SM_CXICON = 11
Private Const SM_CYICON = 12
Private Const SM_CXCURSOR = 13
Private Const SM_CYCURSOR = 14
Private Const SM_CYMENU = 15
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Private Const SM_CYKANJIWINDOW = 18
Private Const SM_MOUSEPRESENT = 19
Private Const SM_CYVSCROLL = 20
Private Const SM_CXHSCROLL = 21
Private Const SM_DEBUG = 22
Private Const SM_SWAPBUTTON = 23
Private Const SM_RESERVED1 = 24
Private Const SM_RESERVED2 = 25
Private Const SM_RESERVED3 = 26
Private Const SM_RESERVED4 = 27
Private Const SM_CXMIN = 28
Private Const SM_CYMIN = 29
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const SM_CXMINTRACK = 34
Private Const SM_CYMINTRACK = 35
Private Const SM_CXDOUBLECLK = 36
Private Const SM_CYDOUBLECLK = 37
Private Const SM_CXICONSPACING = 38
Private Const SM_CYICONSPACING = 39
Private Const SM_MENUDROPALIGNMENT = 40
Private Const SM_PENWINDOWS = 41
Private Const SM_DBCSENABLED = 42
Private Const SM_CMOUSEBUTTONS = 43
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Private Const SM_CXSIZEFRAME = SM_CXFRAME
Private Const SM_CYSIZEFRAME = SM_CYFRAME
Private Const SM_SECURE = 44
Private Const SM_CXEDGE = 45
Private Const SM_CYEDGE = 46
Private Const SM_CXMINSPACING = 47
Private Const SM_CYMINSPACING = 48
Private Const SM_CXSMICON = 49
Private Const SM_CYSMICON = 50
Private Const SM_CYSMCAPTION = 51
Private Const SM_CXSMSIZE = 52
Private Const SM_CYSMSIZE = 53
Private Const SM_CXMENUSIZE = 54
Private Const SM_CYMENUSIZE = 55
Private Const SM_ARRANGE = 56
Private Const SM_CXMINIMIZED = 57
Private Const SM_CYMINIMIZED = 58
Private Const SM_CXMAXTRACK = 59
Private Const SM_CYMAXTRACK = 60
Private Const SM_CXMAXIMIZED = 61
Private Const SM_CYMAXIMIZED = 62
Private Const SM_NETWORK = 63
Private Const SM_CLEANBOOT = 67
Private Const SM_CXDRAG = 68
Private Const SM_CYDRAG = 69
Private Const SM_SHOWSOUNDS = 70
Private Const SM_CXMENUCHECK = 71 'Use instead of GetMenuCheckMarkDimensions()!
Private Const SM_CYMENUCHECK = 72
Private Const SM_SLOWMACHINE = 73
Private Const SM_MIDEASTENABLED = 74
' Return values for ExcludeClipRect
Private Const NULLREGION = 1
Private Const SIMPLEREGION = 2
Private Const COMPLEXREGION = 3
' Hatch constants for CreateHatchBrush
Private Const HS_HORIZONTAL = 0
Private Const HS_VERTICAL = 1
Private Const HS_FDIAGONAL = 2
Private Const HS_BDIAGONAL = 3
Private Const HS_CROSS = 4
Private Const HS_DIAGCROSS = 5
Private Const HS_FDIAGONAL1 = 6
Private Const HS_BDIAGONAL1 = 7
Private Const HS_SOLID = 8
Private Const HS_DENSE1 = 9
Private Const HS_DENSE2 = 10
Private Const HS_DENSE3 = 11
Private Const HS_DENSE4 = 12
Private Const HS_DENSE5 = 13
Private Const HS_DENSE6 = 14
Private Const HS_DENSE7 = 15
Private Const HS_DENSE8 = 16
Private Const HS_NOSHADE = 17
Private Const HS_HALFTONE = 18
Private Const HS_SOLIDCLR = 19
Private Const HS_DITHEREDCLR = 20
Private Const HS_SOLIDTEXTCLR = 21
Private Const HS_DITHEREDTEXTCLR = 22
Private Const HS_SOLIDBKCLR = 23
Private Const HS_DITHEREDBKCLR = 24
Private Const HS_API_MAX = 25
' Image List draw constants
Private Const ILD_NORMAL = &H0
Private Const ILD_TRANSPARENT = &H1
Private Const ILD_MASK = &H10
Private Const ILD_IMAGE = &H20
'' Image type for DrawState
Private Const DST_COMPLEX = &H0
Private Const DST_TEXT = &H1
Private Const DST_PREFIXTEXT = &H2
Private Const DST_ICON = &H3
Private Const DST_BITMAP = &H4
' ' State type for DrawState
Private Const DSS_NORMAL = &H0
Private Const DSS_UNION = &H10
Private Const DSS_DISABLED = &H20
Private Const DSS_MONO = &H80
Private Const DSS_RIGHT = &H8000
' SysColor constants *some could be wrong in the code*
Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_ADJ_MAX = 100
Private Const COLOR_ADJ_MIN = -100
Private Const COLOR_APPWORKSPACE = 12
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_GRAYTEXT = 17
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_INACTIVEBORDER = 11
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Const COLOR_BTNDKSHADOW = 21
Private Const COLOR_BTNLIGHT = 22
Private Const COLOR_MENU = 4
Private Const COLOR_MENUBAR = 30
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_SCROLLBAR = 0
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_WINDOWTEXT = 8
' Owner draw actions
Private Const ODA_DRAWENTIRE = &H1
Private Const ODA_SELECT = &H2
Private Const ODA_FOCUS = &H4
' Owner draw state
Private Const ODS_SELECTED = &H1
Private Const ODS_GRAYED = &H2
Private Const ODS_DISABLED = &H4
Private Const ODS_CHECKED = &H8
Private Const ODS_FOCUS = &H10
Private Const ODS_DEFAULT = &H20
Private Const ODS_COMBOBOXEDIT = &H1000
'required for font API functions
Private Const LF_FACESIZE = 32
Private Const SYMBOL_CHARSET = 2
Private Const LOGPIXELSY = 90
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
'for subclassing
Private Const GWL_WNDPROC = -4
'for BitBlt
Private Const NOTSRCERASE = &H1100A6
Private Const NOTSRCCOPY = &H330008
Private Const SRCERASE = &H440328
Private Const SRCINVERT = &H660046
Private Const SRCAND = &H8800C6
Private Const MERGEPAINT = &HBB0226
Private Const MERGECOPY = &HC000CA
Private Const SRCCOPY = &HCC0020
Private Const SRCPAINT = &HEE0086
Private Const PATPAINT = &HFB0A09
Private Const BLACKNESS = &H42
Private Const DSTINVERT = &H550009
Private Const PATINVERT = &H5A0049
Private Const PATCOPY = &HF00021
Private Const WHITENESS = &HFF0062
Private Const MAGICROP = &HB8074A
' Background Modes
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
' DrawText constants
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const ODT_MENU = 1
Private Const MNC_IGNORE = 0
Private Const MNC_CLOSE = 1
Private Const MNC_EXECUTE = 2
Private Const MNC_SELECT = 3
' Menu Item Info Mask constants
Private Const MIIM_STATE = &H1&
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_CHECKMARKS = &H8
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Const MIIM_STRING = &H40
Private Const MIIM_BITMAP = &H80
Private Const MIIM_FTYPE = &H100
Private Const MF_INSERT = &H0
Private Const MF_CHANGE = &H80
Private Const MF_APPEND = &H100
Private Const MF_DELETE = &H200
Private Const MF_REMOVE = &H1000
Private Const MF_BYCOMMAND = &H0
Private Const MF_BYPOSITION = &H400
Private Const MF_SEPARATOR = &H800
Private Const MF_ENABLED = &H0
Private Const MF_GRAYED = &H1
Private Const MF_DISABLED = &H2
Private Const MF_UNCHECKED = &H0
Private Const MF_CHECKED = &H8
Private Const MF_USECHECKBITMAPS = &H200
Private Const MF_STRING = &H0
Private Const MF_BITMAP = &H4
Private Const MF_OWNERDRAW = &H100
Private Const MF_POPUP = &H10
Private Const MF_MENUBARBREAK = &H20
Private Const MF_MENUBREAK = &H40
Private Const MF_UNHILITE = &H0
Private Const MF_HILITE = &H80
Private Const MF_DEFAULT = &H1000
Private Const MF_SYSMENU = &H2000
Private Const MF_HELP = &H4000
Private Const MF_RIGHTJUSTIFY = &H4000
Private Const MF_MOUSESELECT = &H8000
Private Const MF_END = &H80 ' ' Obsolete -- only used by old RES files
Private Const MFT_STRING = MF_STRING
Private Const MFT_BITMAP = MF_BITMAP
Private Const MFT_MENUBARBREAK = MF_MENUBARBREAK
Private Const MFT_MENUBREAK = MF_MENUBREAK
Private Const MFT_OWNERDRAW = MF_OWNERDRAW
Private Const MFT_RADIOCHECK = &H200
Private Const MFT_SEPARATOR = MF_SEPARATOR
Private Const MFT_RIGHTORDER = &H2000
Private Const MFT_RIGHTJUSTIFY = MF_RIGHTJUSTIFY
Private Const MFS_GRAYED = &H3
Private Const MFS_DISABLED = MFS_GRAYED
Private Const MFS_CHECKED = MF_CHECKED
Private Const MFS_HILITE = MF_HILITE
Private Const MFS_ENABLED = MF_ENABLED
Private Const MFS_UNCHECKED = MF_UNCHECKED
Private Const MFS_UNHILITE = MF_UNHILITE
Private Const MFS_DEFAULT = MF_DEFAULT
' Menu item drawing constants
Private Const CXGAP = 1 ' num pixels between button and text
Private Const CXTEXTMARGIN = 2 ' num pixels after hilite to start text
Private Const CXBUTTONMARGIN = 2 ' num pixels wider button is than bitmap
Private Const CYBUTTONMARGIN = 2 ' ditto for height
' 3D border styles
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
' Border flags
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_DIAGONAL = &H10
Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
Private Const BF_MIDDLE = &H800 ' Fill in the middle
Private Const BF_SOFT = &H1000 ' For softer buttons
Private Const BF_ADJUST = &H2000 ' Calculate the space left over
Private Const BF_FLAT = &H4000 ' For flat rather than 3D borders
Private Const BF_MONO = &H8000 ' For monochrome borders
' Window messages
Private Const WM_WINDOWPOSCHANGED = &H47
Private Const WM_ACTIVATE = &H6
Private Const WM_DRAWITEM = &H2B
Private Const WM_ERASEBKGND = &H14
Private Const WM_GETFONT = &H31
Private Const WM_GETMINMAXINFO = &H24
Private Const WM_MEASUREITEM = &H2C
Private Const WM_NCHITTEST = &H84
Private Const WM_NCLBUTTONUP = &HA2
Private Const WM_NCRBUTTONUP = &HA5
Private Const WM_MENUSELECT = &H11F
Private Const WM_MENUCHAR = &H120
Private Const WM_NOTIFY = &H4E
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_INITMENU = &H116
Private Const WM_SETCURSOR = &H20
Private Const WM_SYSCOMMAND = &H112
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SIZE
cx As Long
cy 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 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
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte '0=false; 255=true
lfUnderline As Byte '0=f; 255=t
lfStrikeOut As Byte '0=f; 255=t
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type TEXTMETRIC
tmHeight As Long
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 OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private bIsWinXP As Boolean
Private Type IMAGEINFO
hbmImage As Long
hbmMask As Long
Unused1 As Long
Unused2 As Long
rcImage As RECT
End Type
' Bitmap objects for quick redrawing
Private m_bmpChecked As Long, m_bmpRadioed As Long
Private m_MarlettFont As Long 'Font used to draw Window items
Private m_iBitmapWidth As Integer 'width of menu bitmaps (square)
Private m_SideBitmapWidth As Long
Private pmds As CMyItemDatas 'the collection of pmd
Private WndCol As Collection 'the collection of WndCoolMenu
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, K As Byte
Dim info As MENUITEMINFO
Dim dwItemData As Long
Dim pmd As CMyItemData
Dim Text As String
Dim ByteBuffer() As Byte
' Get the number of menu items
Dim nItem As Long
nItem& = GetMenuItemCount(hMenu&)
'On GetmenuItemCount error, exit
If nItem& = -1 Then Exit Sub
For i& = 0 To nItem& - 1
'Create and initialize a byte array
ReDim ByteBuffer(0 To 200) As Byte
For K = 0 To 200
ByteBuffer(K) = 0
Next K
'information to retreive with GetMenuItemInfo
info.fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE Or MIIM_STATE Or MIIM_SUBMENU
info.dwTypeData = VarPtr(ByteBuffer(0))
info.cch = UBound(ByteBuffer)
info.cbSize = LenB(info) 'size in byte of structure
Call GetMenuItemInfo(hMenu&, i&, MF_BYPOSITION, info)
dwItemData& = info.dwItemData
If bSysMenu And (info.wID >= &HF000) Then _
GoTo NextGoto 'not touching
info.fMask = 0& 'reset mask value
If bShowButtons Then
'showing buttons. if not, no OwnerDraw needed
If Not CBool(info.fType And MFT_OWNERDRAW) Then
'Convert if not OWNERDRAW
info.fType = info.fType Or MFT_OWNERDRAW
info.fMask = info.fMask Or MIIM_TYPE Or MIIM_STATE
If dwItemData& = 0& Then
info.dwItemData = CLng(pmds.Count + 1)
info.fMask = info.fMask Or MIIM_DATA Or MIIM_STATE
Set pmd = pmds.Add(CStr(info.dwItemData))
Text$ = Left(StrConv(ByteBuffer, vbUnicode), info.cch)
pmd.sMenuText = Text$
Dim iBreakPos As Integer
iBreakPos% = InStr(Text$, "|")
If iBreakPos% Then
Dim iBreak2Pos As Integer
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 * 1
cFirstChar$ = Left(Text$, 1)
If cFirstChar$ = "-" Then
info.fType = info.fType Or MF_SEPARATOR
If pmd.sMenuHelp = "" Then _
pmd.sMenuText = Right(Text$, Len(Text$) - 1)
End If
pmd.bAsMark = (cFirstChar$ = "*") Or (cFirstChar$ = "#")
If pmd.bAsMark Then
pmd.bAsCheck = (cFirstChar$ = "#")
If pmd.sMenuHelp = "" Then _
pmd.sMenuText = Right(Text$, Len(Text$) - 1)
Else
If Mid(Text$, 3, 1) = " " Then
If InStr("123456789", Mid(Text$, 2, 1)) > 0 And cFirstChar$ = "&" Then
pmd.bAsMark = True
pmd.bAsCheck = False
End If
End If
End If
'get image index
If Permanent Then
pmd.iButton = -1
Else
pmd.iButton = GetButtonIndex(hWnd&, pmd.sMenuText)
End If
pmd.fType = info.fType
pmd.fState = info.fState
pmd.bTrueSub = (info.hSubMenu <> 0&) And (Not Permanent)
Else
'A reference exists
Set pmd = pmds(CStr(dwItemData&))
End If
pmd.bMainMenu = Permanent ' it's a main menu
End If 'Changed to OWNERDRAW
If Not Permanent Then _
Call WndCol(CStr(hWnd&)).AddMenuHead(hMenu)
Else
'No buttons
If info.fType And MFT_OWNERDRAW Then
info.fType = info.fType And (Not MFT_OWNERDRAW)
info.fMask = info.fMask Or MIIM_TYPE Or MIIM_STATE
Set pmd = pmds(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 MFT_SEPARATOR Then
cLeadChar$ = "-"
info.fType = info.fType And (Not MFT_SEPARATOR)
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
'remove reference
info.dwItemData = 0&
info.fMask = info.fMask Or MIIM_DATA
pmds.Remove CStr(dwItemData&) 'by key
End If
End If
' make changes if any
If info.fMask Then _
Call SetMenuItemInfo(hMenu&, i&, MF_BYPOSITION, info)
NextGoto:
Next i&
Set pmd = Nothing
ErrorHandle:
End Sub
Private Sub OnInitMenuPopup(hWnd As Long, hMenu As Long, nIndex As Long, bSysMenu As Boolean)
WndCol(CStr(hWnd&)).MainPoppedIndex = -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
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
Dim Text As String
Dim iAmpersand As Integer
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%)
'Build an array of matching elements
ItemMatch(Count%) = i&
Count% = Count% + 1
End If
End If
'Identify the selected menu item
If info.fState And MFS_HILITE Then _
iCurrent% = i&
Next i&
Count% = Count% - 1 'back
If Count% = -1 Then 'no match
OnMenuChar = 0&
Exit Function
End If
Dim bMainMenu As Boolean
bMainMenu = pmds(CStr(dwItemData&)).bMainMenu
If Count% = 0 Then '1 match
OnMenuChar = MAKELONG(ItemMatch(0), MNC_EXECUTE)
Exit Function
End If
Dim iSelect As Integer 'multiple matches
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, Optional bBold As Boolean = False)
Dim LeftStr As String
Dim RightStr As String
Dim iTabPos As Integer
Dim OldFont As Long
Dim hNewFont As Long
LeftStr$ = Text$
iTabPos = InStr(LeftStr$, Chr(9)) ' 9 = tab
If iTabPos > 0 Then
RightStr$ = Right$(LeftStr$, Len(LeftStr$) - iTabPos)
LeftStr$ = Left$(LeftStr$, iTabPos - 1)
End If
Call SetTextColor(hDC&, Color&)
hNewFont& = GetMenuFont(hWnd&, True, bBold)
OldFont& = SelectObject(hDC&, hNewFont&)
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&)
DeleteObject hNewFont&
DeleteObject 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 WndObj As WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
Dim dwItemData As Long
dwItemData& = lpds.itemData
If (dwItemData& = 0&) Or (lpds.CtlType <> ODT_MENU) Or (dwItemData& > pmds.Count) Then
OnDrawItem = False
Exit Function
End If
Dim pmd As CMyItemData
Set pmd = pmds(CStr(dwItemData&))
Dim hDC As Long
hDC& = lpds.hDC
LSet rtItem = lpds.rcItem
If pmd.fType And MFT_SEPARATOR Then
LSet rt = rtItem
LSet rtText = rtItem
Dim SepMargin As Integer
SepMargin = 3 '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
Dim OldFont As Long
OldFont& = SelectObject(hDC&, GetMenuFontSep(hWnd&))
rtText = OffsetRect(rtText, 1, 1)
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&)
DeleteObject OldFont&
End If
Else
Dim bDisabled As Boolean
Dim bSelected As Boolean
Dim bChecked As Boolean
Dim bHaveButn As Boolean
bDisabled = lpds.itemState And ODS_GRAYED
bSelected = lpds.itemState And ODS_SELECTED
bChecked = lpds.itemState And ODS_CHECKED
bHaveButn = False
Dim iButton As Integer
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)
Call ImageList_Draw(WndObj.ilHandle.hImageList, iButton%, hDC&, rtIcon.Left, rtIcon.Top, ILD_TRANSPARENT)
Else
Dim hIcon As Long
hIcon& = ImageList_GetIcon(WndObj.ilHandle.hImageList, iButton%, 0&)
Call DrawEmbossed(hDC&, WndObj.ilHandle.hImageList, iButton%, rtIcon, WndObj.ColorEmbossed)
End If
Else
Dim info As MENUITEMINFO
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
Dim iButnWidth As Integer
iButnWidth% = m_iBitmapWidth% + CXBUTTONMARGIN
Dim dwColorBG As Long
dwColorBG = IIf(bSelected And WndObj.FullSelect, WndObj.SelectColor&, IIf(pmd.bMainMenu And bIsWinXP, GetSysColor(COLOR_MENUBAR), GetSysColor(COLOR_MENU)))
LSet rtText = rtItem
If pmd.bMainMenu Then Call FillRectEx(hDC&, rtItem, IIf(bIsWinXP, GetSysColor(COLOR_MENUBAR), 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)
Dim dwSelTextColor As Long
dwSelTextColor& = GetSysColor(COLOR_HIGHLIGHTTEXT)
Dim dwColorText As Long
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&)))
Dim TextOffset As Integer
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, CBool(pmd.fState And MFS_DEFAULT))
Call DrawMenuText(hWnd&, hDC&, rtText, pmd.sMenuText, dwColorText&, Not pmd.bMainMenu, WndObj.RightToLeft, CBool(pmd.fState And MFS_DEFAULT))
End If
'Draws the arrows of submenus
If pmd.bTrueSub Then
Dim rtArrow As RECT
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
Set pmd = Nothing
OnDrawItem = True
ErrHandler:
End Function
Private Function OnMeasureItem(hWnd As Long, ByRef miPtr As Long) As Boolean
Dim lpms As MEASUREITEMSTRUCT
Dim hNewFont As Long
Call CopyMemory(lpms, ByVal miPtr, Len(lpms))
Dim dwItemData As Long
dwItemData& = lpms.itemData
If (dwItemData& = 0&) Or (lpms.CtlType <> ODT_MENU) Then
OnMeasureItem = False
Exit Function
End If
Dim pmd As CMyItemData
Set pmd = pmds(CStr(dwItemData&))
Dim iCYMENU As Integer
iCYMENU% = GetSystemMetrics(SM_CYMENU)
Dim rc As RECT
Dim rcHeight As Integer
Dim OldFont As Long
Dim hWndDC As Long
If pmd.fType And MFT_SEPARATOR Then
hWndDC& = GetDC(hWnd&)
hNewFont& = GetMenuFont(hWnd&, True, CBool(pmd.fState And MFS_DEFAULT))
OldFont& = SelectObject(hWndDC&, hNewFont&)
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&)
'DeleteObject OldFont&
ElseIf Left(pmd.sMenuText, 1) = "!" Then
lpms.itemHeight = 0
lpms.itemWidth = 0
Else
hWndDC& = GetDC(hWnd&)
hNewFont& = GetMenuFont(hWnd&, True, CBool(pmd.fState And MFS_DEFAULT))
OldFont& = SelectObject(hWndDC&, hNewFont&)
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&)
'DeleteObject OldFont&
rcHeight = rc.Bottom - rc.Top
lpms.itemHeight = IIf(rcHeight > iCYMENU%, rcHeight, iCYMENU%)
Dim itemWidth As Long
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))
DeleteObject hNewFont&
Set pmd = Nothing
OnMeasureItem = True
End Function
Public Function GetMenuFont(hWnd As Long, Optional bForceReset As Boolean = False, Optional bBold As Boolean = False) As Long
Dim WndObj As WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
If (WndObj.MenuFont = 0) Or bForceReset Then
Dim sText As String
Dim TextLen As Long
Dim tLF As LOGFONT
Dim tm As TEXTMETRIC
If WndObj.FontName = "" Then
sText$ = Space$(255)
TextLen& = Len(sText$)
'Window's DC
Dim hWndDC As Long: hWndDC& = GetDC(hWnd&)
'Font Name
TextLen& = GetTextFace(hWndDC&, TextLen&, sText$)
WndObj.FontName = Left$(sText$, TextLen&)
'Form's fore color
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
'If FontName specified, use it + defined size
If bBold = True Then
tLF.lfWeight = FW_BOLD
Else
tLF.lfWeight = FW_NORMAL
End If
Dim hDC As Long: hDC& = GetWindowDC(hWnd&)
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)
GetMenuFont& = CreateFontIndirect(tLF)
Set WndObj = Nothing
Exit Function
End If
GetMenuFont& = WndObj.MenuFont&
Set WndObj = Nothing
End Function
Private Function GetMenuFontSep(hWnd As Long) As Long
Dim WndObj As WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
If WndObj.MenuFontSep& = 0& Then
Dim tLF As LOGFONT
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 HelpCallBack, Optional ilHandle As Object) As Boolean
m_iBitmapWidth% = 16
m_SideBitmapWidth = 0
Dim verinfo As OSVERSIONINFO
verinfo.dwOSVersionInfoSize = Len(verinfo)
GetVersionEx verinfo
If verinfo.dwMajorVersion > 5 Or (verinfo.dwMajorVersion = 5 And verinfo.dwMinorVersion > 0) Then
bIsWinXP = True
Else
bIsWinXP = False
End If
If wndHandle <> 0 Then
If WndCol Is Nothing Then
Set WndCol = New Collection
Set pmds = New CMyItemDatas
End If
Dim NewWnd As WndCoolMenu
Set NewWnd = New WndCoolMenu
NewWnd.hWnd = wndHandle&
NewWnd.PrevProc = GetWindowLong(wndHandle&, GWL_WNDPROC)
NewWnd.SelectColor = GetSysColor(COLOR_HIGHLIGHT)
Call SetWindowLong(wndHandle&, GWL_WNDPROC, AddressOf WindowProc)
If Not (ilHandle Is Nothing) Then _
Set NewWnd.ilHandle = ilHandle
If Not (HelpObj Is Nothing) Then _
Set NewWnd.HelpObj = HelpObj
NewWnd.SCMainMenu = True
WndCol.Add NewWnd, CStr(wndHandle&)
Set NewWnd = Nothing
'Main menu permanent subclassing
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_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 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 WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
Dim info As MENUITEMINFO
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(CStr(info.dwItemData)).sMenuText, pmds(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
Dim i As Integer
For i% = 0 To WndObj.CountMenuHeads
Call ConvertMenu(hWnd&, WndObj.GetMenuHead(i%), 0&, False, False)
Next i%
WndObj.MainPoppedIndex = -1
End If
Set WndObj = Nothing
ErrHandler:
End Sub
Private Function GetButtonIndex(hWnd As Long, ByVal sMenuText As String) As Integer
Dim m_ilHandle As Object
Dim i As Integer
GetButtonIndex = -1
Set m_ilHandle = WndCol(CStr(hWnd)).ilHandle
If InStr(sMenuText, vbTab) Then sMenuText = Left(sMenuText, InStr(sMenuText, vbTab) - 1)
If Not (m_ilHandle Is Nothing) Then
For i = 1 To m_ilHandle.ListImages.Count
If UCase(sMenuText) = UCase(m_ilHandle.ListImages(i).Tag) Then
GetButtonIndex = i - 1
Exit Function
End If
Continue:
Next i
End If
Set m_ilHandle = Nothing
End Function
Private Function BSTRtoLPSTR(sBSTR As String, B() As Byte, lpsz As Long) As Long
Dim cBytes As Long
'Get the number of bytes in the string
cBytes = LenB(sBSTR)
'Redim the array to hold it + 2 for Unicode null
ReDim B(1 To cBytes + 2) As Byte
Dim sABSTR As String
'Set sABSTR to ASCII equivalent
sABSTR = StrConv(sBSTR, vbFromUnicode)
'Get a long pointer to the string
lpsz = StrPtr(sABSTR)
CopyMemory B(1), ByVal lpsz, cBytes + 2
lpsz = VarPtr(B(1))
BSTRtoLPSTR = cBytes
End Function
Private Sub DrawEmbossed(hDC As Long, ilHandle As Long, iButnIndex As Integer, rt As RECT, bInColor As Boolean)
Dim info As IMAGEINFO
Dim rcImage As RECT
Call ImageList_GetImageInfo(ilHandle&, iButnIndex%, info)
Dim cx As Integer, cy As Integer
LSet rcImage = info.rcImage
cx% = rcImage.Right - rcImage.Left
cy% = rcImage.Bottom - rcImage.Top
' // create memory dc
Dim hmemDC As Long
hmemDC& = CreateCompatibleDC(hDC&)
' // create mono or color bitmap
Dim hBitmap As Long
If bInColor Then
hBitmap& = CreateCompatibleBitmap(hDC&, cx%, cy%)
Else
hBitmap& = CreateBitmap(cx%, cy%, 1, 1, vbNull)
End If
' // draw image into memory DC--fill BG white first
Dim hOldBitmap As Long
hOldBitmap = SelectObject(hmemDC&, hBitmap&)
Call PatBlt(hmemDC&, 0, 0, cx%, cy%, WHITENESS)
Call ImageList_Draw(ilHandle&, iButnIndex%, hmemDC&, 0, 0, ILD_TRANSPARENT)
Dim hOldBackColor As Long
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 WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
Dim cx As Integer, cy As Integer
cx% = rc.Right - rc.Left
cy% = rc.Bottom - rc.Top
If Not CBool(hBmp) Then
Dim hmemDC As Long
Dim hBmpTemp As Long
Dim hOldBmp As Long
Dim hBrush As Long
Dim lbInfo As LOGBRUSH
Dim hOldBrush As Long
If WndObj.ComplexChecks Then
hmemDC& = CreateCompatibleDC(hDC&)
Dim rcHighLigth As RECT
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&)
Dim x As Long: x = 0
Dim y As Long: y = 0
If bCheck Then x = x + 13
If bDisabled Then x = x + 26
y = 0
Dim hOldBackColor As Long
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
'm_bmpRadioed contains the image mask of the round box
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
Dim i As Integer
Dim BitArray(0 To 3) As Long
For i = 0 To 3
BitArray(i) = MAKELONG(170, 85) '&HAA &H55 = 10101010
' 01010101
Next i
Dim hPat As Long
hPat& = CreateBitmap(8&, 8&, 1&, 1&, BitArray(0))
Dim hPatBrush As Long
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
End If
Draw3DMark = True
Set WndObj = Nothing
hError:
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 WndCoolMenu
Set WndObj = WndCol(CStr(hWnd&))
If WndObj.MainPoppedIndex = -2 Or GetActiveWindow() <> hWnd Then
Set WndObj = Nothing
Exit Function
End If
'Get the main menu handle from the window handle
Dim hMenu As Long: hMenu& = GetMenu(hWnd&)
'This block is for MDI apps
'the work area doesn't send the message I used so I use two msg
If MousePosition <> 5 And MousePosition > 0 Then GoTo NOPOP
If MousePosition = 5 Then
Set WndObj = Nothing
Exit Function
End If
Dim dwPAPI As Double
Dim pAPI As POINTAPI
'Get the position of the hit from lParam&
pAPI.x = LoWord(lParam&)
pAPI.y = HiWord(lParam&)
Call CopyMemory(dwPAPI, pAPI, LenB(pAPI))
Dim MenuHitIndex As Long
MenuHitIndex& = MenuItemFromPoint(hWnd&, hMenu&, dwPAPI)
'No popped item, erase the old one if exists and exit
If MenuHitIndex& = -1 Then GoTo NOPOP
Dim PoppedIndex As Long
PoppedIndex& = WndObj.MainPoppedIndex
'If the old and new pop are the same, don't redraw
'If MenuHitIndex& = PoppedIndex& Then
' Set WndObj = Nothing
' Exit Function
'End If
Dim info As MENUITEMINFO
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
'Erase the old pop if exists and return
If PoppedIndex& <> -1 Then GoSub DRAWFLAT
Dim MenuRect As RECT
'Get the new pop rect
Call GetMenuItemRect(hWnd&, hMenu&, MenuHitIndex&, MenuRect)
'Set the old pop reference with the new pop
WndObj.MainPoppedIndex = MenuHitIndex&
'Draw on the screen DC
hDC& = GetDC(0&) 'Get the screen DC
Call DrawEdge(hDC&, MenuRect, BDR_RAISEDINNER, BF_RECT)
Call ReleaseDC(0&, hDC&)
OnDrawMainMenu = True
Set WndObj = Nothing
Exit Function
NOPOP:
'Draw flat if there's a popped item
If WndObj.MainPoppedIndex > -1 Then
GoSub DRAWFLAT
WndObj.MainPoppedIndex = -1
End If
Set WndObj = Nothing
Exit Function
DRAWFLAT:
'Erase old hit with flat edges
Dim OldPoppedRect As RECT
'Get the old hit's rect
Call GetMenuItemRect(hWnd&, hMenu&, CLng(WndObj.MainPoppedIndex), OldPoppedRect)
'Draw on the screen DC
hDC& = GetDC(0&) 'Get the screen DC
Call DrawEdge(hDC&, OldPoppedRect, BDR_RAISEDINNER, BF_RECT Or BF_FLAT)
Call ReleaseDC(0&, hDC&)
Return
End Function
Private Sub PrintGlyph(hDC As Long, Glyph As String, Color As Long, rt As RECT, ByVal wFormat As Long)
Dim m_MarlettFont As Long
Dim tLF As LOGFONT
tLF.lfFaceName = "Marlett" + Chr(0)
tLF.lfCharSet = SYMBOL_CHARSET
tLF.lfHeight = 13
m_MarlettFont& = CreateFontIndirect(tLF)
'write text with transparent background
Call SetBkMode(hDC&, TRANSPARENT)
Dim hOldFont As Long
'Select the font for the device context
hOldFont& = SelectObject(hDC&, m_MarlettFont&)
DeleteObject hOldFont&
DeleteObject m_MarlettFont&
'select the color for the glyph
Call SetTextColor(hDC&, Color&)
Call DrawText(hDC&, Glyph, 1, rt, wFormat&)
End Sub
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo ErrorHandle
Dim rc As RECT
Dim WndDC As Long
Dim hOldFont As Long
Select Case uMsg&
Case WM_SETCURSOR:
Call OnDrawMainMenu(hWnd&, 0&, LoWord(lParam&))
Case WM_NCHITTEST:
Call OnDrawMainMenu(hWnd&, lParam&, -1)
Case WM_MEASUREITEM:
If OnMeasureItem(hWnd&, lParam&) Then
WindowProc = True
Exit Function
End If
Case WM_DRAWITEM:
Dim di As DRAWITEMSTRUCT
CopyMemory di, ByVal lParam, Len(di)
If di.hwndItem = MainForm.SBar.hWnd Then
If di.itemID = 0 And MainForm.SBar.Panels(1).Text = "0 Servers (Click Here to Update)" Then
Dim OldTextColor As Long
Dim TextSize As SIZE
OldTextColor = GetTextColor(di.hDC)
SetBkMode di.hDC, TRANSPARENT
di.rcItem.Left = di.rcItem.Left + 3
DrawText di.hDC, "0 Servers (", 11, di.rcItem, DT_VCENTER
GetTextExtentPoint32 di.hDC, "0 Servers (", 11, TextSize
SetTextColor di.hDC, GetSysColor(COLOR_HIGHLIGHT)
di.rcItem.Left = di.rcItem.Left + TextSize.cx
DrawText di.hDC, "Click Here to Update", 20, di.rcItem, DT_VCENTER
GetTextExtentPoint32 di.hDC, "Click Here to Update", 20, TextSize
SetTextColor di.hDC, OldTextColor
di.rcItem.Left = di.rcItem.Left + TextSize.cx
DrawText di.hDC, ")", 1, di.rcItem, DT_VCENTER
Exit Function
ElseIf di.itemID = 2 And MainForm.SBar.Panels(3).Visible Then
SetBkMode di.hDC, TRANSPARENT
SetTextColor di.hDC, GetSysColor(COLOR_HIGHLIGHT)
di.rcItem.Left = di.rcItem.Left + 3
DrawText di.hDC, "Cancel", 6, di.rcItem, DT_VCENTER
Exit Function
End If
End If
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 uMsg&, ByVal wParam&, ByVal lParam&)
Call OnInitMenuPopup(hWnd&, wParam&, LoWord(lParam&), CBool(HiWord(lParam&)))
WindowProc = 0&
Exit Function
Case WM_MENUCHAR:
Dim Result As Long
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
Case WM_GETMINMAXINFO
FSMWindowProc hWnd, uMsg, wParam, lParam
WindowProc = 0&
Exit Function
Case WM_SYSCOMMAND
FSMWindowProc hWnd, uMsg, wParam, lParam
Case WM_NOTIFY
Dim ReturnVal As Long
ReturnVal = LVPSCWindowProc(hWnd, uMsg, wParam, lParam)
If ReturnVal > 0 Then
WindowProc = ReturnVal
Exit Function
End If
Case WM_ERASEBKGND, WM_ACTIVATE
If bReg_Valid = True Then GoTo Continue
WindowProc& = CallWindowProc(WndCol(CStr(hWnd&)).PrevProc, hWnd&, uMsg&, wParam&, lParam&)
GetWindowRect hWnd, rc
rc.Right = rc.Right - rc.Left - GetSystemMetrics(SM_CXBORDER) - (GetSystemMetrics(SM_CXDLGFRAME) * 2)
rc.Left = 0
rc.Top = GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYCAPTION)
rc.Bottom = rc.Top + GetSystemMetrics(SM_CYMENU)
WndDC = GetWindowDC(hWnd)
SetBkMode WndDC, TRANSPARENT
SetTextColor WndDC, vbRed
MainForm.FontBold = True
hOldFont = SelectObject(WndDC, SendMessage(hWnd, WM_GETFONT, 0, 0))
MainForm.FontBold = False
DrawText WndDC, "UNREGISTERED", 12, rc, DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE
Call SelectObject(WndDC, hOldFont)
ReleaseDC hWnd, WndDC
Exit Function
Case WM_NCLBUTTONUP, WM_NCRBUTTONUP
If bReg_Valid = True Or ((uMsg = WM_NCLBUTTONUP And IsMouseSwapped() = True) Or _
(uMsg = WM_NCRBUTTONUP And IsMouseSwapped() = False)) Then GoTo Continue
Dim TextCX As SIZE
GetWindowRect hWnd, rc
rc.Right = rc.Right - GetSystemMetrics(SM_CXBORDER) - (GetSystemMetrics(SM_CXDLGFRAME) * 2)
rc.Top = rc.Top + GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYCAPTION)
rc.Bottom = rc.Top + GetSystemMetrics(SM_CYMENU)
WndDC = GetWindowDC(hWnd)
MainForm.FontBold = True
hOldFont = SelectObject(WndDC, SendMessage(hWnd, WM_GETFONT, 0, 0))
MainForm.FontBold = False
GetTextExtentPoint32 WndDC, "UNREGISTERED", 12, TextCX
Call SelectObject(WndDC, hOldFont)
ReleaseDC hWnd, WndDC
rc.Left = rc.Right - TextCX.cx
If PtInRect(rc, LoWord(lParam), HiWord(lParam)) Then MainForm.ShowRegFormTimer.Enabled = True
End Select
Continue:
WindowProc& = CallWindowProc(WndCol(CStr(hWnd&)).PrevProc, hWnd&, uMsg&, wParam&, lParam&)
ErrorHandle:
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 RightToLeft(hWnd As Long, Optional value As Variant) As Boolean
On Error Resume Next
If IsMissing(value) Then
RightToLeft = WndCol(CStr(hWnd&)).RightToLeft
Else
WndCol(CStr(hWnd&)).RightToLeft = value
RightToLeft = value
End If
End Function
Public Function FullSelect(hWnd As Long, Optional value As Variant) As Boolean
On Error Resume Next
If IsMissing(value) Then
FullSelect = WndCol(CStr(hWnd&)).FullSelect
Else
WndCol(CStr(hWnd&)).FullSelect = value
FullSelect = value
End If
End Function
Public Function FontSize(hWnd As Long, Optional value As Variant) As Long
On Error Resume Next
If IsMissing(value) Then
FontSize = WndCol(CStr(hWnd&)).FontSize
Else
WndCol(CStr(hWnd&)).FontSize = value
Call DrawMenuBar(hWnd&)
FontSize = value
End If
End Function
Public Function ForeColor(hWnd As Long, Optional value As Variant) As Long
On Error Resume Next
If IsMissing(value) Then
ForeColor = WndCol(CStr(hWnd&)).ForeColor
Else
WndCol(CStr(hWnd&)).ForeColor = value
Call DrawMenuBar(hWnd&)
ForeColor = value
End If
End Function
Public Function FontName(hWnd As Long, Optional value As Variant) As String
On Error Resume Next
If IsMissing(value) Then
FontName = WndCol(CStr(hWnd&)).FontName
Else
WndCol(CStr(hWnd&)).FontName = value
Call DrawMenuBar(hWnd&)
FontName = value
End If
End Function
Public Sub MDIChildMenu(hWnd As Long)
On Error Resume Next
Dim ParentWnd As Long: ParentWnd& = GetParent(GetParent(hWnd&))
Dim WndObj As WndCoolMenu
Set WndObj = WndCol(CStr(ParentWnd&))
If Not (WndObj Is Nothing) Then
If WndObj.SCMainMenu Then WndObj.SCMainMenu = GetMenu(ParentWnd&)
End If
Set WndObj = Nothing
End Sub
Public Function MakeRop4(fore As RasterOpConstants, back As RasterOpConstants) As Long
MakeRop4 = MAKELONG(0, MakeWord(0, LoByte(LoWord(back)))) Or fore
End Function
Download QuickQuery HL Edition/mCoolMenu.bas