vbAccelerator - Contents of code file: mMenu.bas

Attribute VB_Name = "mMenu"
Option Explicit

' =======================================================================
' MENU Declares:
' =======================================================================
' Menu information:
Public Type tMenuItem
   sHelptext As String
   sInputCaption As String
   sCaption As String
   sAccelerator As String
   sShortCutDisplay As String
   iShortCutShiftMask As Integer
   iShortCutShiftKey As Integer
   lID As Long
   lActualID As Long       ' The ID gets modified if we add a sub-menu to the
    hMenu of the popup
   lItemData As Long
   lIndex As Long
   lParentId As Long
   lIconIndex As Long
   bChecked As Boolean
   bRadioCheck As Boolean
   bEnabled As Boolean
   hMenu As Long
   lHeight As Long
   lWidth As Long
   bCreated As Boolean
   bIsAVBMenu As Boolean
   lShortCutStartPos As Long
   bMarkToDestroy As Boolean
   sKey As String
   lParentIndex As Long
   bTitle As Boolean
   bDefault As Boolean
   bOwnerDraw As Boolean
   bMenuBarBreak As Boolean
   bMenuBreak As Boolean
   bVisible As Boolean
   bDragOff As Boolean
   bInfrequent As Boolean
   bTextBox As Boolean
   bComboBox As Boolean
   bChevronAppearance As Boolean
   bChevronBehaviour As Boolean
   bShowCheckAndIcon As Boolean
End Type

Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    ItemData As Long
End Type

' Menu flag constants:
Public Const MF_APPEND = &H100&
Public Const MF_BITMAP = &H4&
Public Const MF_BYCOMMAND = &H0&
Public Const MF_BYPOSITION = &H400&
Public Const MF_CALLBACKS = &H8000000
Public Const MF_CHANGE = &H80&
Public Const MF_CHECKED = &H8&
Public Const MF_CONV = &H40000000
Public Const MF_DELETE = &H200&
Public Const MF_DISABLED = &H2&
Public Const MF_ENABLED = &H0&
Public Const MF_END = &H80
Public Const MF_ERRORS = &H10000000
Public Const MF_GRAYED = &H1&
Public Const MF_HELP = &H4000&
Public Const MF_HILITE = &H80&
Public Const MF_HSZ_INFO = &H1000000
Public Const MF_INSERT = &H0&
Public Const MF_LINKS = &H20000000
Public Const MF_MASK = &HFF000000
Public Const MF_MENUBARBREAK = &H20&
Public Const MF_MENUBREAK = &H40&
Public Const MF_MOUSESELECT = &H8000&
Public Const MF_OWNERDRAW = &H100&
Public Const MF_POPUP = &H10&
Public Const MF_POSTMSGS = &H4000000
Public Const MF_REMOVE = &H1000&
Public Const MF_SENDMSGS = &H2000000
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const MF_SYSMENU = &H2000&
Public Const MF_UNCHECKED = &H0&
Public Const MF_UNHILITE = &H0&
Public Const MF_USECHECKBITMAPS = &H200&
Public Const MF_DEFAULT = &H1000&

'#define MFT_STRING          MF_STRING
'#define MFT_BITMAP          MF_BITMAP
'#define MFT_MENUBARBREAK    MF_MENUBARBREAK
'#define MFT_MENUBREAK       MF_MENUBREAK
'#define MFT_OWNERDRAW       MF_OWNERDRAW
Public Const MFT_RADIOCHECK = &H200&
'#define MFT_SEPARATOR       MF_SEPARATOR
Public Const MFT_RIGHTORDER = &H2000&
'private const MFT_RIGHTJUSTIFY    MF_RIGHTJUSTIFY

' New versions of the names...
Public Const MFS_GRAYED = &H3&
Public Const MFS_DISABLED = MFS_GRAYED
Public Const MFS_CHECKED = MF_CHECKED
Public Const MFS_HILITE = MF_HILITE
Public Const MFS_ENABLED = MF_ENABLED
Public Const MFS_UNCHECKED = MF_UNCHECKED
Public Const MFS_UNHILITE = MF_UNHILITE
Public Const MFS_DEFAULT = MF_DEFAULT

Public Const MIIM_STATE = &H1&
Public Const MIIM_ID = &H2&
Public Const MIIM_SUBMENU = &H4&
Public Const MIIM_CHECKMARKS = &H8&
Public Const MIIM_TYPE = &H10&
Public Const MIIM_DATA = &H20&

' Track popup menu constants:
Public Const TPM_CENTERALIGN = &H4&
Public Const TPM_RIGHTALIGN = &H8&
Public Const TPM_RIGHTBUTTON = &H2&

Public Const TPM_NONOTIFY = &H80&           '/_Don/index.html't send any notification
 msgs */
Public Const TPM_HORIZONTAL = &H0          '/* Horz alignment matters more */

' Owner draw information:
Public Const ODS_CHECKED = &H8
Public Const ODS_DISABLED = &H4
Public Const ODS_FOCUS = &H10
Public Const ODS_GRAYED = &H2
Public Const ODS_SELECTED = &H1
Public Const ODT_BUTTON = 4
Public Const ODT_COMBOBOX = 3
Public Const ODT_LISTBOX = 2
Public Const ODT_MENU = 1

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

Type MENUITEMTEMPLATE
        mtOption As Integer
        mtID As Integer
        mtString As Byte
End Type
Type MENUITEMTEMPLATEHEADER
        versionNumber As Integer
        offset As Integer
End Type

Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As
 Long) As Long
Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert
 As Long) As Long
Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long)
 As Long

Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As
 Long) As Long
Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal
 fByPos As Long, ByVal gmdiFlags As Long) As Long
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal
 hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As
 MENUITEMINFO) As Long
Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal
 hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As
 MENUITEMINFO) As Long
Declare Function GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu
 As Long, ByVal uItem As Long, lprcItem As RECT) As Long
Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As
 Long, ByVal wFlags As Long) As Long

Declare Function CreateMenu Lib "user32" () As Long
Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Declare Function CreatePopupMenu Lib "user32" () As Long

Declare Function AppendMenuBylong Lib "user32" Alias "AppendMenuA" (ByVal hMenu
 As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As
 Long) As Long
Declare Function AppendMenuByString Lib "user32" Alias "AppendMenuA" (ByVal
 hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem
 As String) As Long
Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition
 As Long, ByVal wFlags As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As
 Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long,
 ByVal lpString As Any) As Long
Declare Function ModifyMenuByLong Lib "user32" Alias "ModifyMenuA" (ByVal hMenu
 As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As
 Long, ByVal lpString As Long) As Long
Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition
 As Long, ByVal wFlags As Long) As Long
Declare Function InsertMenuByLong Lib "user32" Alias "InsertMenuA" (ByVal hMenu
 As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As
 Long, ByVal lpNewItem As Long) As Long
Declare Function InsertMenuByString Lib "user32" Alias "InsertMenuA" (ByVal
 hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem
 As Long, ByVal lpNewItem As String) As Long
Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal
 hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByVal lpcMenuItemInfo
 As MENUITEMINFO) As Long

Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal
 wIDCheckItem As Long, ByVal wCheck As Long) As Long
Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal
 un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal
 wIDEnableItem As Long, ByVal wEnable As Long) As Long
Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal hMenu
 As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long

Declare Function MenuItemFromPoint Lib "user32" (ByVal hwnd As Long, ByVal
 hMenu As Long, ByVal ptScreen As POINTAPI) As Long
Declare Function TrackPopupMenuByLong Lib "user32" Alias "TrackPopupMenu"
 (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long,
 ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
 (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal
 dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments
 As Long) As Long

Private Const WH_KEYBOARD As Long = 2
Private Const MSGF_MENU = 2
Private Const HC_ACTION = 0
Private Declare Function SetWindowsHookEx Lib "user32" Alias
 "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpFn As Long, ByVal hmod As
 Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long)
 As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long,
 ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Public Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Public Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Public Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc
 As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, iPic As IPicture)
 As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer


' Work DC
Private m_hdcMono As Long
Private m_hbmpMono As Long
Private m_hBmpOld As Long

' Keyboard hook (for accelerators):
Private m_hKeyHook As Long
Private m_lKeyHookPtr() As Long
Private m_iKeyHookCount As Long


Public Function WinAPIError(ByVal lLastDLLError As Long) As String
Dim sBuff As String
Dim lCount As Long
    
    ' Return the error message associated with LastDLLError:
    sBuff = String$(256, 0)
    lCount = FormatMessage( _
    FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
    0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
    If lCount Then
    WinAPIError = Left$(sBuff, lCount)
End If

End Function




Public Function DrawEdge( _
      ByVal hdc As Long, _
      qrc As RECT, _
      ByVal edge As Long, _
      ByVal grfFlags As Long, _
      ByVal bOfficeXpStyle As Boolean _
   ) As Long
   If (bOfficeXpStyle) Then
      Dim junk As POINTAPI
      Dim hPenOld As Long
      Dim hPen As Long
      If (qrc.Bottom > qrc.Top) Then
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbHighlight))
      Else
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vb3DShadow))
      End If
      hPenOld = SelectObject(hdc, hPen)
      MoveToEx hdc, qrc.Left, qrc.Top, junk
      LineTo hdc, qrc.Right - 1, qrc.Top
      If (qrc.Bottom > qrc.Top) Then
         LineTo hdc, qrc.Right - 1, qrc.Bottom - 1
         LineTo hdc, qrc.Left, qrc.Bottom - 1
         LineTo hdc, qrc.Left, qrc.Top
      End If
      SelectObject hdc, hPenOld
      DeleteObject hPen
   Else
      DrawEdgeAPI hdc, qrc, edge, grfFlags
   End If
End Function

Public Sub ImageListDrawIcon( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hdc As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        Optional ByVal bSelected As Boolean = False, _
        Optional ByVal bBlend25 As Boolean = False _
    )
Dim lFlags As Long
Dim lR As Long

    lFlags = ILD_TRANSPARENT
    If (bSelected) Then
        lFlags = lFlags Or ILD_SELECTED
    End If
    If (bBlend25) Then
        lFlags = lFlags Or ILD_BLEND25
    End If
    If (ptrVb6ImageList <> 0) Then
        Dim o As Object
        On Error Resume Next
        Set o = ObjectFromPtr(ptrVb6ImageList)
        If Not (o Is Nothing) Then
            o.ListImages(iIconIndex + 1).Draw hdc, lX * Screen.TwipsPerPixelX,
             lY * Screen.TwipsPerPixelY, lFlags
        End If
        On Error GoTo 0
    Else
        lR = ImageList_Draw( _
                hIml, _
                iIconIndex, _
                hdc, _
                lX, _
                lY, _
                lFlags)
        If (lR = 0) Then
            Debug.Print "Failed to draw Image: " & iIconIndex & " onto hDC " &
             hdc, "ImageListDrawIcon"
        End If
    End If
End Sub
Public Sub ImageListDrawIconDisabled( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hdc As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        ByVal lSize As Long, _
        Optional ByVal asShadow As Boolean _
    )
Dim lR As Long
Dim hIcon As Long

   hIcon = 0
   If (ptrVb6ImageList <> 0) Then
      Dim o As Object
      On Error Resume Next
      Set o = ObjectFromPtr(ptrVb6ImageList)
      If Not (o Is Nothing) Then
          hIcon = o.ListImages(iIconIndex + 1).ExtractIcon()
      End If
      On Error GoTo 0
   Else
      hIcon = ImageList_GetIcon(hIml, iIconIndex, 0)
   End If
   If (hIcon <> 0) Then
      If (asShadow) Then
         Dim hBr As Long
         hBr = GetSysColorBrush(vb3DShadow And &H1F)
         lR = DrawState(hdc, hBr, 0, hIcon, 0, lX, lY, lSize, lSize, DST_ICON
          Or DSS_MONO)
         DeleteObject hBr
      Else
         lR = DrawState(hdc, 0, 0, hIcon, 0, lX, lY, lSize, lSize, DST_ICON Or
          DSS_DISABLED)
      End If
      DestroyIcon hIcon
   End If
   
End Sub
Public Property Get BlendColor(ByVal oColorFrom As OLE_COLOR, ByVal oColorTo As
 OLE_COLOR) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lCRetR As Long
Dim lCRetG As Long
Dim lCRetB As Long
   lCRetR = (lCFrom And &HFF) + ((lCTo And &HFF) - (lCFrom And &HFF)) \ 2
   lCRetG = ((lCFrom \ &H100) And &HFF&) + (((lCTo \ &H100) And &HFF&) -
    ((lCFrom \ &H100) And &HFF&)) \ 2
   lCRetB = ((lCFrom \ &H10000) And &HFF&) + (((lCTo \ &H10000) And &HFF&) -
    ((lCFrom \ &H10000) And &HFF&)) \ 2
   BlendColor = RGB(lCRetR, lCRetG, lCRetB)
End Property
Public Property Get LighterColour(ByVal oColor As OLE_COLOR) As Long
Dim lC As Long
Dim h As Single, s As Single, l As Single
Dim lR As Long, lG As Long, lB As Long
Static s_lColLast As Long
Static s_lLightColLast As Long
   
   lC = TranslateColor(oColor)
   If (lC <> s_lColLast) Then
      s_lColLast = lC
      RGBToHLS lC And &HFF&, (lC \ &H100) And &HFF&, (lC \ &H10000) And &HFF&,
       h, s, l
      If (l > 0.99) Then
         l = l * 0.8
      Else
         l = l * 1.1
         If (l > 1) Then
            l = 1
         End If
      End If
      HLSToRGB h, s, l, lR, lG, lB
      s_lLightColLast = RGB(lR, lG, lB)
   End If
   LighterColour = s_lLightColLast
End Property
Public Property Get SlightlyLighterColour(ByVal oColor As OLE_COLOR) As Long
Dim lC As Long
Dim h As Single, s As Single, l As Single
Dim lR As Long, lG As Long, lB As Long
Static s_lColLast As Long
Static s_lLightColLast As Long
   
   lC = TranslateColor(oColor)
   If (lC <> s_lColLast) Then
      s_lColLast = lC
      RGBToHLS lC And &HFF&, (lC \ &H100) And &HFF&, (lC \ &H10000) And &HFF&,
       h, s, l
      If (l > 0.99) Then
         l = l * 0.95
      Else
         l = l * 1.05
         If (l > 1) Then
            l = 1
         End If
      End If
      HLSToRGB h, s, l, lR, lG, lB
      s_lLightColLast = RGB(lR, lG, lB)
   End If
   SlightlyLighterColour = s_lLightColLast
End Property
Public Property Get NoPalette(Optional ByVal bForce As Boolean = False) As
 Boolean
Static bOnce As Boolean
Static bNoPalette As Boolean
Dim lHDC As Long
Dim lBits As Long
   If (bForce) Then
      bOnce = False
   End If
   If Not (bOnce) Then
      lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
      If (lHDC <> 0) Then
         lBits = GetDeviceCaps(lHDC, BITSPIXEL)
         If (lBits <> 0) Then
            bOnce = True
         End If
         bNoPalette = (lBits > 8)
         DeleteDC lHDC
      End If
   End If
   NoPalette = bNoPalette
End Property

Public Sub RGBToHLS( _
     ByVal r As Long, ByVal g As Long, ByVal b As Long, _
     h As Single, s As Single, l As Single _
     )
 Dim Max As Single
 Dim Min As Single
 Dim delta As Single
 Dim rR As Single, rG As Single, rB As Single

     rR = r / 255: rG = g / 255: rB = b / 255

 '{Given: rgb each in [0,1].
 ' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
         Max = Maximum(rR, rG, rB)
         Min = Minimum(rR, rG, rB)
             l = (Max + Min) / 2 '{This is the lightness}
         '{Next calculate saturation}
         If Max = Min Then
             'begin {Acrhomatic case}
             s = 0
             h = 0
             'end {Acrhomatic case}
         Else
             'begin {Chromatic case}
                 '{First calculate the saturation.}
             If l <= 0.5 Then
                 s = (Max - Min) / (Max + Min)
             Else
                 s = (Max - Min) / (2 - Max - Min)
             End If
             '{Next calculate the hue.}
             delta = Max - Min
             If rR = Max Then
                     h = (rG - rB) / delta '{Resulting color is between yellow
                      and magenta}
             ElseIf rG = Max Then
                 h = 2 + (rB - rR) / delta '{Resulting color is between cyan
                  and yellow}
             ElseIf rB = Max Then
                 h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                  and cyan}
             End If
         'end {Chromatic Case}
     End If
 End Sub

 Public Sub HLSToRGB( _
     ByVal h As Single, ByVal s As Single, ByVal l As Single, _
     r As Long, g As Long, b As Long _
     )
 Dim rR As Single, rG As Single, rB As Single
 Dim Min As Single, Max As Single

     If s = 0 Then
     ' Achromatic case:
     rR = l: rG = l: rB = l
     Else
     ' Chromatic case:
     ' delta = Max-Min
     If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
     Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
     End If
     ' Get the Max value:
     Max = 2 * l - Min
     
     ' Now depending on sector we can evaluate the h,l,s:
     If (h < 1) Then
         rR = Max
         If (h < 0) Then
             rG = Min
             rB = rG - h * (Max - Min)
         Else
             rB = Min
             rG = h * (Max - Min) + rB
         End If
     ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
             rB = Min
             rR = rB - (h - 2) * (Max - Min)
         Else
             rR = Min
             rB = (h - 2) * (Max - Min) + rR
         End If
     Else
         rB = Max
         If (h < 4) Then
             rR = Min
             rG = rR - (h - 4) * (Max - Min)
         Else
             rG = Min
             rR = (h - 4) * (Max - Min) + rG
         End If
         
     End If
             
     End If
     r = rR * 255: g = rG * 255: b = rB * 255
 End Sub
 Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
     If (rR > rG) Then
     If (rR > rB) Then
         Maximum = rR
     Else
         Maximum = rB
     End If
     Else
     If (rB > rG) Then
         Maximum = rB
     Else
         Maximum = rG
     End If
     End If
 End Function
 Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
     If (rR < rG) Then
     If (rR < rB) Then
         Minimum = rR
     Else
         Minimum = rB
     End If
     Else
     If (rB < rG) Then
         Minimum = rB
     Else
         Minimum = rG
     End If
 End If
 End Function
Public Sub ClearUpWorkDC()
   If m_hBmpOld <> 0 Then
      SelectObject m_hdcMono, m_hBmpOld
      m_hBmpOld = 0
   End If
   If m_hbmpMono <> 0 Then
      DeleteObject m_hbmpMono
      m_hbmpMono = 0
   End If
   If m_hdcMono <> 0 Then
      DeleteDC m_hdcMono
      m_hdcMono = 0
   End If
End Sub
Public Sub DrawMaskedFrameControl( _
    ByVal hDCDest As Long, _
    ByRef trWhere As RECT, _
    ByVal kind As DFCFlags, _
    ByVal style As Long _
   )
Dim hbrMenu As Long, hbrStockWhite As Long
Dim saveBkMode As Long, saveBkColor As Long, saveBrush As Long
Dim tRWhereOnTmp As RECT
Dim bgcolor As Long
Static s_lLastRight As Long, s_lLastBottom As Long

   With tRWhereOnTmp
      .Right = trWhere.Right - trWhere.Left
      .Bottom = trWhere.Bottom - trWhere.Top
      If .Right > s_lLastRight Or .Bottom > s_lLastBottom Or (m_hdcMono = 0) Or
       (m_hbmpMono = 0) Or (m_hBmpOld = 0) Then
         ClearUpWorkDC
         ' Create memory device context for our temporary mask
         m_hdcMono = CreateCompatibleDC(0)
         If m_hdcMono <> 0 Then
            ' Create monochrome bitmap and select it into DC
            m_hbmpMono = CreateCompatibleBitmap(m_hdcMono, .Right, .Bottom)
            If m_hbmpMono <> 0 Then
               m_hBmpOld = SelectObject(m_hdcMono, m_hbmpMono)
               SetBkColor m_hdcMono, &HFFFFFF
            End If
         End If
         If m_hBmpOld = 0 Then
            ' Failed...
            ClearUpWorkDC
         End If
      End If
      s_lLastRight = .Right
      s_lLastBottom = .Bottom
   End With
   
   
   DrawFrameControl m_hdcMono, tRWhereOnTmp, kind, style
   ' We have black where tick & white elsewhere
   SetBkColor hDCDest, &HFFFFFF
   BitBlt hDCDest, trWhere.Left, trWhere.Top, trWhere.Right, trWhere.Bottom,
    m_hdcMono, 0, 0, vbSrcAnd

   ' Clean up everything.
   If saveBrush <> 0 Then
      SelectObject hDCDest, saveBrush
   End If
   If hbrMenu <> 0 Then
      DeleteObject hbrMenu
   End If
   If saveBkMode <> 0 Then
      SetBkMode hDCDest, saveBkMode
   End If
   If saveBkColor <> 0 Then
      SetBkColor hDCDest, saveBkColor
   End If
    
End Sub

Public Sub DrawGradient( _
      ByVal hdc As Long, _
      ByRef rct As RECT, _
      ByVal lEndColour As Long, _
      ByVal lStartColour As Long, _
      ByVal bVertical As Boolean _
   )
Dim lStep As Long
Dim lPos As Long, lSize As Long
Dim bRGB(1 To 3) As Integer
Dim bRGBStart(1 To 3) As Integer
Dim dR(1 To 3) As Double
Dim dPos As Double, d As Double
Dim hBr As Long
Dim tR As RECT
   
   LSet tR = rct
   If bVertical Then
      lSize = (tR.Bottom - tR.Top)
   Else
      lSize = (tR.Right - tR.Left)
   End If
   lStep = lSize \ 255
   If (lStep < 3) Then
       lStep = 3
   End If
       
   bRGB(1) = lStartColour And &HFF&
   bRGB(2) = (lStartColour And &HFF00&) \ &H100&
   bRGB(3) = (lStartColour And &HFF0000) \ &H10000
   bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
   dR(1) = (lEndColour And &HFF&) - bRGB(1)
   dR(2) = ((lEndColour And &HFF00&) \ &H100&) - bRGB(2)
   dR(3) = ((lEndColour And &HFF0000) \ &H10000) - bRGB(3)
        
   For lPos = lSize To 0 Step -lStep
      ' Draw bar:
      If bVertical Then
         tR.Top = tR.Bottom - lStep
      Else
         tR.Left = tR.Right - lStep
      End If
      If tR.Top < rct.Top Then
         tR.Top = rct.Top
      End If
      If tR.Left < rct.Left Then
         tR.Left = rct.Left
      End If
      
      'Debug.Print tR.Right, tR.left, (bRGB(3) * &H10000 + bRGB(2) * &H100& +
       bRGB(1))
      hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
      FillRect hdc, tR, hBr
      DeleteObject hBr
            
      ' Adjust colour:
      dPos = ((lSize - lPos) / lSize)
      If bVertical Then
         tR.Bottom = tR.Top
         bRGB(1) = bRGBStart(1) + dR(1) * dPos
         bRGB(2) = bRGBStart(2) + dR(2) * dPos
         bRGB(3) = bRGBStart(3) + dR(3) * dPos
      Else
         tR.Right = tR.Left
         bRGB(1) = bRGBStart(1) + dR(1) * dPos
         bRGB(2) = bRGBStart(2) + dR(2) * dPos
         bRGB(3) = bRGBStart(3) + dR(3) * dPos
      End If
      
   Next lPos

End Sub
      
Private Property Get PopupMenuFromPtr(ByVal lPtr As Long) As cPopupMenu
Dim oTemp As Object
   If lPtr <> 0 Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory oTemp, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set PopupMenuFromPtr = oTemp
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory oTemp, 0&, 4
      ' OK, hit the End button if you must--you'll probably still crash,
      ' but it will be because of the subclass, not the uncounted reference
   End If
End Property

Private Function KeyboardFilter(ByVal nCode As Long, ByVal wParam As Long,
 ByVal lparam As Long) As Long
Dim bKeyUp As Boolean
Dim bAlt As Boolean, bCtrl As Boolean, bShift As Boolean
Dim bFKey As Boolean, bEscape As Boolean, bDelete As Boolean
Dim wMask As KeyCodeConstants
Dim cT As cPopupMenu
Dim i As Long

On Error GoTo ErrorHandler

   If nCode = HC_ACTION And m_iKeyHookCount > 0 Then
      ' Key up or down:
      bKeyUp = ((lparam And &H80000000) = &H80000000)
      If Not bKeyUp Then
         bShift = (GetAsyncKeyState(vbKeyShift) <> 0)
         bAlt = ((lparam And &H20000000) = &H20000000)
         bCtrl = (GetAsyncKeyState(vbKeyControl) <> 0)
         bFKey = ((wParam >= vbKeyF1) And (wParam <= vbKeyF12))
         bEscape = (wParam = vbKeyEscape)
         bDelete = (wParam = vbKeyDelete)
         If bAlt Or bCtrl Or bFKey Or bEscape Or bDelete Then
            wMask = Abs(bShift * vbShiftMask) Or Abs(bCtrl * vbCtrlMask) Or
             Abs(bAlt * vbAltMask)
            For i = m_iKeyHookCount To 1 Step -1
               If m_lKeyHookPtr(i) <> 0 Then
                  ' Alt- or Ctrl- key combination pressed:
                  Set cT = PopupMenuFromPtr(m_lKeyHookPtr(i))
                  If Not cT Is Nothing Then
                     If cT.AcceleratorPress(wParam, wMask) Then
                        KeyboardFilter = 1
                        Exit Function
                     End If
                  End If
               End If
            Next i
         End If
      End If
   End If
   KeyboardFilter = CallNextHookEx(m_hKeyHook, nCode, wParam, lparam)

   Exit Function
   
ErrorHandler:
   Debug.Print "Keyboard Hook Error!"
   Exit Function

End Function
Public Sub AttachKeyboardHook(cThis As cPopupMenu)
Dim lpFn As Long
Dim lPtr As Long
Dim i As Long
   
   If m_iKeyHookCount = 0 Then
      lpFn = HookAddress(AddressOf KeyboardFilter)
      m_hKeyHook = SetWindowsHookEx(WH_KEYBOARD, lpFn, 0&, GetCurrentThreadId())
      Debug.Assert (m_hKeyHook <> 0)
   End If
   lPtr = ObjPtr(cThis)
   For i = 1 To m_iKeyHookCount
      If lPtr = m_lKeyHookPtr(i) Then
         ' we already have it:
         Debug.Assert False
         Exit Sub
      End If
   Next i
   ReDim Preserve m_lKeyHookPtr(1 To m_iKeyHookCount + 1) As Long
   m_iKeyHookCount = m_iKeyHookCount + 1
   m_lKeyHookPtr(m_iKeyHookCount) = lPtr
   
End Sub
Public Sub DetachKeyboardHook(cThis As cPopupMenu)
Dim i As Long
Dim lPtr As Long
Dim iThis As Long
   
   lPtr = ObjPtr(cThis)
   For i = 1 To m_iKeyHookCount
      If m_lKeyHookPtr(i) = lPtr Then
         iThis = i
         Exit For
      End If
   Next i
   If iThis <> 0 Then
      If m_iKeyHookCount > 1 Then
         For i = iThis To m_iKeyHookCount - 1
            m_lKeyHookPtr(i) = m_lKeyHookPtr(i + 1)
         Next i
      End If
      m_iKeyHookCount = m_iKeyHookCount - 1
      If m_iKeyHookCount >= 1 Then
         ReDim Preserve m_lKeyHookPtr(1 To m_iKeyHookCount) As Long
      Else
         Erase m_lKeyHookPtr
      End If
   Else
      ' Trying to detach a toolbar which was never attached...
      ' This will happen at design time
   End If
   
   If m_iKeyHookCount <= 0 Then
      If (m_hKeyHook <> 0) Then
         UnhookWindowsHookEx m_hKeyHook
         m_hKeyHook = 0
      End If
   End If
   
End Sub
Private Function HookAddress(ByVal lPtr As Long) As Long
   HookAddress = lPtr
End Function


Public Function BitmapToPicture(ByVal hBmp As Long) As IPicture

    If (hBmp = 0) Then Exit Function
    
    Dim oNewPic As Picture, tPicConv As PictDesc, IGuid As Guid
    
    ' Fill PictDesc structure with necessary parts:
    With tPicConv
    .cbSizeofStruct = Len(tPicConv)
    .picType = vbPicTypeBitmap
    .hImage = hBmp
    End With
    
    ' Fill in IDispatch Interface ID
    With IGuid
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With
    
    ' Create a picture object:
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    
    ' Return it:
    Set BitmapToPicture = oNewPic
    

End Function