vbAccelerator - Contents of code file: uKeyTest2.ctl

VERSION 5.00
Begin VB.UserControl uKeyTest2 
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.Label lblKeyDown 
      Height          =   315
      Left            =   60
      TabIndex        =   3
      Top             =   420
      Width           =   2535
   End
   Begin VB.Label lblKey 
      Height          =   315
      Left            =   60
      TabIndex        =   2
      Top             =   840
      Width           =   2535
   End
   Begin VB.Label lblKeyUp 
      Height          =   315
      Left            =   60
      TabIndex        =   1
      Top             =   1260
      Width           =   2535
   End
   Begin VB.Label lblFocus 
      Caption         =   "Not In Focus"
      Height          =   255
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   4635
   End
End
Attribute VB_Name = "uKeyTest2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' ===========================================================================
' Filename:    uKeyTest2.ctl
' Author:      Steve McMahon
' Date:        21 January 1999
'
' Requires:    OleGuids.tlb (in IDE only)
'              mIOLEInPlaceActiveObject.bas
'              SSUBTMR.DLL
'
' Description:
' Demonstrates how to trap the tab-key in a UserControl, if you
' *really* want to do it properly!
'
' ---------------------------------------------------------------------------
' Visit vbAccelerator, advanced, free source for VB programmers
'     http://vbaccelerator.com
' ===========================================================================

Implements ISubclass
Private m_IPAOHookStruct As IPAOHookStruct
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_SETFOCUS = &H7
Private m_hWnd As Long
Private m_bInterceptTabs As Boolean
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer

Private Property Get ShiftState() As Integer
   ' we don't need to consider Alt for a Tab key press.
   ShiftState = GetAsyncKeyState(vbKeyShift) * vbShiftMask Or
    GetAsyncKeyState(vbKeyControl) * vbCtrlMask
End Property

Public Property Get InterceptTabs() As Boolean
   InterceptTabs = m_bInterceptTabs
End Property
Public Property Let InterceptTabs(ByVal bState As Boolean)
   m_bInterceptTabs = bState
End Property
Friend Function TranslateAccelerator(lpMsg As VBOleGuids.MSG) As Long
   TranslateAccelerator = S_FALSE
   If (m_bInterceptTabs) Then
      ' Here you can modify the response to the key down
      ' accelerator command using the values in lpMsg.  This
      ' can be used to capture Tabs, Returns, Arrows etc.
      ' Just process the message as required and return S_OK.
      If (lpMsg.wParam And &HFFFF&) = vbKeyTab Then
         Select Case lpMsg.message
         Case WM_KEYDOWN
            UserControl_KeyDown vbKeyTab, ShiftState
            TranslateAccelerator = S_OK
         Case WM_KEYUP
            UserControl_KeyUp vbKeyTab, ShiftState
            TranslateAccelerator = S_OK
         End Select
      End If
   End If
End Function
Private Sub pInitTabTrap(ByVal bState As Boolean)
   If (m_hWnd <> 0) Then
      DetachMessage Me, m_hWnd, WM_SETFOCUS
   End If
   m_hWnd = 0
   If bState Then
      If UserControl.Ambient.UserMode Then
         m_hWnd = UserControl.hwnd
         AttachMessage Me, m_hWnd, WM_SETFOCUS
      End If
   End If
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
   ISubclass_MsgResponse = emrPreprocess
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
   
   Select Case iMsg
   
   
   ' --------------------------------------------------------------------------
   ' Required to allow Tab keys to be trapped:
   Case WM_SETFOCUS
      If m_bInterceptTabs Then
         Dim pOleObject                  As IOleObject
         Dim pOleInPlaceSite             As IOleInPlaceSite
         Dim pOleInPlaceFrame            As IOleInPlaceFrame
         Dim pOleInPlaceUIWindow         As IOleInPlaceUIWindow
         Dim pOleInPlaceActiveObject     As IOleInPlaceActiveObject
         Dim PosRect                     As RECT
         Dim ClipRect                    As RECT
         Dim FrameInfo                   As OLEINPLACEFRAMEINFO
         Dim grfModifiers                As Long
         Dim AcceleratorMsg              As MSG
      
         'Get in-place frame and make sure it is set to our in-between
         'implementation of IOleInPlaceActiveObject in order to catch
         'TranslateAccelerator calls
         Set pOleObject = Me
         Set pOleInPlaceSite = pOleObject.GetClientSite
         pOleInPlaceSite.GetWindowContext pOleInPlaceFrame,
          pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect),
          VarPtr(FrameInfo)
         CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4
         pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
         If Not pOleInPlaceUIWindow Is Nothing Then
            pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject,
             vbNullString
         End If
         ' Clear up the inbetween implementation:
         CopyMemory pOleInPlaceActiveObject, 0&, 4
      End If
   ' --------------------------------------------------------------------------
     
   End Select
   
   
End Function

Private Sub UserControl_Initialize()
   
   m_bInterceptTabs = True
   
   ' Set up information about this control for
   ' IOleInPlaceActiveObject interface:
   Dim IPAO As IOleInPlaceActiveObject

   With m_IPAOHookStruct
      Set IPAO = Me
      CopyMemory .IPAOReal, IPAO, 4
      CopyMemory .TBEx, Me, 4
      .lpVTable = IPAOVTable
      .ThisPointer = VarPtr(m_IPAOHookStruct)
   End With
   
End Sub

Private Sub UserControl_GotFocus()
   lblFocus.Caption = "Focus"
End Sub

Private Sub UserControl_InitProperties()
   ' Start subclassing for WM_SETFOCUS if runtime:
   pInitTabTrap True
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   lblKeyDown.Caption = KeyCode
   lblKeyUp.Caption = ""
   lblKey.Caption = ""
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   lblKey.Caption = KeyAscii
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
   lblKeyUp.Caption = KeyCode
End Sub

Private Sub UserControl_LostFocus()
   lblFocus.Caption = "Not in Focus"
End Sub


Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   ' Start subclassing for WM_SETFOCUS if runtime:
   pInitTabTrap True
End Sub

Private Sub UserControl_Terminate()
   
   ' Detach the custom IOleInPlaceActiveObject interface
   ' pointers.
   With m_IPAOHookStruct
      CopyMemory .IPAOReal, 0&, 4
      CopyMemory .TBEx, 0&, 4
   End With
   
   ' Stop subclassing for SetFocus:
   pInitTabTrap False
   
End Sub