vbAccelerator - Contents of code file: ctlMnemonics.ctl

VERSION 5.00
Begin VB.UserControl ctlMnemonics 
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   3075
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3075
   ScaleWidth      =   4800
End
Attribute VB_Name = "ctlMnemonics"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' Windows keyboard message constants:
Private Const WM_SYSCHAR& = &H106&
Private Const WM_SYSKEYDOWN& = &H104&

' OleControl Interface support:
Private m_ptrGetControlInfoOrig As Long
Private m_ptrOnMnemonicOrg As Long
Private m_cMnemonics As pcMnemonics

' Tracking focus
Private m_bFocus As Boolean

' Events fired:
Private m_cEvents As New Collection

Public Sub AddMnemonic(ByVal sKey As String)
   m_cMnemonics.AddByKey sKey
   updateMnemonics
End Sub
Public Sub AddShortcut(ByVal vKey As KeyCodeConstants, ByVal eShift As
 ShiftConstants)
Dim eAccelFlag As EAcceleratorFlagConstants
   
   eAccelFlag = eafVirtKey
   If (eShift And vbAltMask = vbAltMask) Then
      eAccelFlag = eAccelFlag Or eafAlt
   End If
   If (eShift And vbCtrlMask = vbCtrlMask) Then
      eAccelFlag = eAccelFlag Or eafControl
   End If
   If (eShift And vbShiftMask = vbShiftMask) Then
      eAccelFlag = eAccelFlag Or eafShift
   End If
   m_cMnemonics.AddByKeyCode vKey, eAccelFlag
   updateMnemonics
   
End Sub

Public Sub ClearMnemonics()
   Set m_cMnemonics = New pcMnemonics
   updateMnemonics
End Sub

Private Sub updateMnemonics()
   If (UserControl.AccessKeys = "") Then
      UserControl.AccessKeys = " "
   Else
      UserControl.AccessKeys = ""
   End If
   UserControl.Refresh
End Sub

Friend Function GetControlInfo(pCI As CONTROLINFO) As Long
   
   Debug.Print "GetControlInfo"
   pCI.cb = LenB(pCI)
   pCI.cAccel = m_cMnemonics.Count
   pCI.hAccel = m_cMnemonics.hAccel
   pCI.dwFlags = 0
   
End Function
Friend Function OnMnemonic(pMsg As MSG) As Long
Dim i As Long
   
   If (pMsg.Message = WM_SYSCHAR Or pMsg.Message = WM_SYSKEYDOWN) Then
      For i = 1 To m_cMnemonics.Count
         If (pMsg.wParam = m_cMnemonics.VirtKey(i)) Then
            
            ' Note if you put a MsgBox here, you will stop the
            ' GotFocus/LostFocus events from firing
            'MsgBox "Mnemonic " & m_cMnemonics.Key(i) & " fired from control "
             & UserControl.Extender.Name, vbInformation
            '
            m_cEvents.Add Format(Now, "Long Time") & "Mnemonic " &
             m_cMnemonics.Key(i) & " fired"
            UserControl.Refresh
            
            Exit For
         End If
      Next i
   End If
   
End Function

Private Sub UserControl_AmbientChanged(PropertyName As String)
   Debug.Print "AmbientChanged", PropertyName
End Sub

Private Sub UserControl_GotFocus()
   m_bFocus = True
   UserControl.Refresh
End Sub

Private Sub UserControl_Initialize()
       
   ' Get the IOLEControl interface of the control
   Dim IOleCtl As IOleControl
   Set IOleCtl = Me
   ' Replace IOLEControl methods:
   m_ptrGetControlInfoOrig = ReplaceVTableEntry( _
      ObjPtr(IOleCtl), _
      IDX_GetControlInfo, _
      AddressOf mIOleControl.IOleControl_GetControlInfo, _
      ObjPtr(Me) _
      )
   m_ptrOnMnemonicOrg = ReplaceVTableEntry( _
      ObjPtr(IOleCtl), _
      IDX_OnMnemonic, _
      AddressOf mIOleControl.IOleControl_OnMnemonic, _
      ObjPtr(Me) _
      )

   ' Create object to manage Mnemonics for this control:
   Set m_cMnemonics = New pcMnemonics
    
End Sub

Private Sub UserControl_LostFocus()
   m_bFocus = False
   UserControl.Refresh
End Sub

Private Sub UserControl_Paint()
Dim i As Long
Dim sMsg As String
      
   sMsg = UserControl.Extender.Name
   sMsg = sMsg & IIf(m_bFocus, "(HasFocus)", "")
   sMsg = sMsg & vbCrLf & vbCrLf
   For i = 1 To m_cMnemonics.Count
      sMsg = sMsg & "Alt+" & m_cMnemonics.Key(i) & vbCrLf
   Next
   sMsg = sMsg & vbCrLf
   For i = m_cEvents.Count To 1 Step -1
      sMsg = sMsg & m_cEvents(i) & vbCrLf
   Next i

   UserControl.Cls
   UserControl.CurrentX = 16
   UserControl.CurrentY = 16
   UserControl.Print sMsg
   
End Sub

Private Sub UserControl_Terminate()
   
   ' Get the IOLEControl interface of the control
   Dim IOleCtl As IOleControl
   Set IOleCtl = Me
   ' Restore IOleControl methods:
   ReplaceVTableEntry _
      ObjPtr(IOleCtl), _
      IDX_GetControlInfo, _
      m_ptrGetControlInfoOrig
   ReplaceVTableEntry _
      ObjPtr(IOleCtl), _
      IDX_OnMnemonic, _
      m_ptrOnMnemonicOrg
      
End Sub