vbAccelerator - Contents of code file: mDeclares.bas

Attribute VB_Name = "mDeclares"
Option Explicit

Public Type POINTAPI
   x As Long
   y As Long
End Type
Public Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Public Type Msg
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
Public Type TPMPARAMS
    cbSize As Long
    rcExclude As RECT
End Type

Public Const TPM_CENTERALIGN = &H4&
Public Const TPM_LEFTALIGN = &H0&
Public Const TPM_LEFTBUTTON = &H0&
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_RETURNCMD = &H100
Public Const TPM_HORIZONTAL = &H0          '/* Horz alignment matters more */
Public Const TPM_VERTICAL = &H40           '/* Vert alignment matters more */

   ' Win98/2000 menu animation and menu within menu options:
Public Const TPM_RECURSE = &H1&
Public Const TPM_HORPOSANIMATION = &H400&
Public Const TPM_HORNEGANIMATION = &H800&
Public Const TPM_VERPOSANIMATION = &H1000&
Public Const TPM_VERNEGANIMATION = &H2000&
   ' Win2000 only:
Public Const TPM_NOANIMATION = &H4000&

Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal
 wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long,
 ByVal hwnd As Long, lprc As RECT) As Long
Public 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
Public Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long,
 ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long,
 lpTPMParams As TPMPARAMS) As Long

' Window MEssages
Public Const WM_DESTROY = &H2
Public Const WM_SIZE = &H5
Public Const WM_SETTEXT = &HC
Public Const WM_ACTIVATEAPP = &H1C
Public Const WM_CANCELMODE = &H1F
Public Const WM_SETCURSOR = &H20
Public Const WM_MEASUREITEM = &H2C
Public Const WM_DRAWITEM = &H2B
Public Const WM_STYLECHANGING = &H7C
Public Const WM_STYLECHANGED = &H7D
Public Const WM_NCCALCSIZE = &H83
Public Const WM_NCPAINT = &H85
Public Const WM_NCACTIVATE = &H86
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_NCLBUTTONUP = &HA2
Public Const WM_NCLBUTTONDBLCLK = &HA3
Public Const WM_KEYDOWN = &H100
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Const WM_INITMENUPOPUP = &H117
Public Const WM_MENUSELECT = &H11F
Public Const WM_MENUCHAR = &H120
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205
Public Const WM_MDIGETACTIVE = &H229
Public Const WM_ENTERMENULOOP = &H211
Public Const WM_EXITMENULOOP = &H212

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
 hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Public 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

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
 Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd
 As Long, ByVal lpString As String) As Long

Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal
 nPos As Long) As Long

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
Private Const WH_KEYBOARD As Long = 2
Private Const WH_MSGFILTER As Long = (-1)
Private Const MSGF_MENU = 2
Private Const HC_ACTION = 0

Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)

' Message filter hook:
Private m_hMsgHook As Long
Private m_lMsgHookPtr As Long

' Keyboard Hook:
Private m_hKeyHook As Long
Private m_lKeyHookPtr() As Long
Private m_lKeyHookCount As Long

Public Sub AttachKeyboardHook(cN As cNCCalcSize)

Dim lpFn As Long
Dim lPtr As Long
Dim i As Long
   If m_hKeyHook = 0 Then
      lpFn = HookAddress(AddressOf KeyboardFilter)
      m_hKeyHook = SetWindowsHookEx(WH_KEYBOARD, lpFn, 0&, GetCurrentThreadId())
      Debug.Assert (m_hKeyHook <> 0)
   End If
   
   lPtr = ObjPtr(cN)
   If GetKeyHookPtrIndex(lPtr) = 0 Then
      m_lKeyHookCount = m_lKeyHookCount + 1
      ReDim Preserve m_lKeyHookPtr(1 To m_lKeyHookCount) As Long
      m_lKeyHookPtr(m_lKeyHookCount) = lPtr
   End If
   
End Sub
Private Function GetKeyHookPtrIndex(ByVal lPtr As Long) As Long
Dim i As Long
   For i = 1 To m_lKeyHookCount
      If m_lKeyHookPtr(i) = lPtr Then
         GetKeyHookPtrIndex = i
         Exit For
      End If
   Next i
End Function
Public Sub DetachKeyboardHook(cN As cNCCalcSize)
Dim lPtr As Long
Dim i As Long
Dim lIdx As Long
      
   lPtr = ObjPtr(cN)
   lIdx = GetKeyHookPtrIndex(lPtr)
   
   If lIdx > 0 Then
      If m_lKeyHookCount > 1 Then
         For i = lIdx To m_lKeyHookCount - 1
            m_lKeyHookPtr(i) = m_lKeyHookPtr(i + 1)
         Next i
         m_lKeyHookCount = m_lKeyHookCount - 1
         ReDim Preserve m_lKeyHookPtr(1 To m_lKeyHookCount) As Long
      Else
         m_lKeyHookCount = 0
         Erase m_lKeyHookPtr
      End If
   End If
   
   If m_lKeyHookCount <= 0 Then
      If (m_hKeyHook <> 0) Then
         UnhookWindowsHookEx m_hKeyHook
         m_hKeyHook = 0
      End If
   End If
   
End Sub
Private Function GetActiveConsumer(ByRef cM As cNCCalcSize) As Boolean
Dim i As Long
   For i = 1 To m_lKeyHookCount
      If Not m_lKeyHookPtr(i) = 0 Then
         Set cM = ObjectFromPtr(m_lKeyHookPtr(i))
         If cM.WindowActive Then
            GetActiveConsumer = True
            Exit Function
         End If
      End If
   Next i
End Function
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 i As Long
Dim lPtr As Long
Dim cM As cNCCalcSize

On Error GoTo ErrorHandler

   If nCode = HC_ACTION And m_hKeyHook > 0 Then
      ' Key up or down:
      bAlt = ((lParam And &H20000000) = &H20000000)
      'Debug.Print "Got HC_ACTION", bAlt
      If bAlt And (wParam > 0) And (wParam <> vbKeyMenu) Then
         bKeyUp = ((lParam And &H80000000) = &H80000000)
         If Not bKeyUp Then
            bShift = (GetAsyncKeyState(vbKeyShift) <> 0)
            bCtrl = (GetAsyncKeyState(vbKeyControl) <> 0)
            bFKey = ((wParam >= vbKeyF1) And (wParam <= vbKeyF12))
            bEscape = (wParam = vbKeyEscape)
            bDelete = (wParam = vbKeyDelete)
            If Not (bCtrl Or bFKey Or bEscape Or bDelete) Then
               If GetActiveConsumer(cM) Then
                  If cM.AltKeyAccelerator(wParam) Then
                     ' Don't pass accelerator on...
                     KeyboardFilter = 1
                     Exit Function
                  End If
               End If
            End If
         End If
      End If
   End If
   KeyboardFilter = CallNextHookEx(m_hKeyHook, nCode, wParam, lParam)

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

Public Sub AttachMsgHook(cThis As cToolbarMenu)
Dim lpFn As Long
   DetachMsgHook
   m_lMsgHookPtr = ObjPtr(cThis)
   lpFn = HookAddress(AddressOf MenuInputFilter)
   m_hMsgHook = SetWindowsHookEx(WH_MSGFILTER, lpFn, 0&, GetCurrentThreadId())
   Debug.Assert (m_hMsgHook <> 0)
End Sub
Public Sub DetachMsgHook()
   If (m_hMsgHook <> 0) Then
      UnhookWindowsHookEx m_hMsgHook
      m_hMsgHook = 0
   End If
End Sub

'////////////////
'// Menu filter hook just passes to virtual CMenuBar function
'//
Private Function MenuInputFilter(ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long) As Long
Dim cM As cToolbarMenu
Dim lpMsg As Msg
   If nCode = MSGF_MENU Then
      If Not m_lMsgHookPtr = 0 Then
         Set cM = ObjectFromPtr(m_lMsgHookPtr)
         CopyMemory lpMsg, ByVal lParam, Len(lpMsg)
         If (cM.MenuInput(lpMsg)) Then
            MenuInputFilter = 1
            Exit Function
         End If
      End If
   End If
   MenuInputFilter = CallNextHookEx(m_hMsgHook, nCode, wParam, lParam)
End Function


Private Function HookAddress(ByVal lPtr As Long) As Long
   HookAddress = lPtr
End Function

Public Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set ObjectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
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 LogEvent(ByVal sLog As String)
'Dim sFile As String
'Dim iFile As Long
'   sFile = "C:\s.txt"
'   iFile = FreeFile
'   Open sFile For Append As #iFile
'   Print #iFile, sLog
'   Close #iFile
End Sub