Les contrôles ActiveX implémentent l'interface IOleInPlaceActiveObject qui gère les interfaces entre lui même et son parent, notamment son activation, l'aide contextuelle, le dessin et la retaille des bordures ainsi que la réponse aux touches d'accélérations.

Lorsque vous développez un contrôle utilisateur avec Visual Basic, l'implémentation de cette interface est prédéfinie en standard par Visual Basic et indisponible au développeur.

Cet exemple montre comment remplacer l'implémentation par défaut en utilisant le contrôle Active SubClass Hook & Timer.

Cette interception de l'interface par défaut est absolument nécessaire à réaliser si vous créez un contrôle en utilisant l'API Windows et la fonction CreateWindowEx, en effet Visual Basic ne gère que la fenêtre UserControl et non la fenêtre fille créée par votre code, les traitements par défaut des touches d'accélérations deviennent innopérants.

La classe IInPlaceActiveObject est une classe d'instantiation PublicNotCreatable, elle doit être utilisée sous la forme d'une clause Implements IInPlaceActiveObject. Il est impératif ensuite d'implementer la propriété IInPlaceActiveObject_TranslateAccelerator pour gérer la manière dont le message est consommé et la fonction ISubClass_WindowProc pour le traitement du message en question.

Contrôle Utilsateur IPAO.ctl

Option Explicit

Implements ISubclass
Implements IInPlaceActiveObject

Private mInterceptTab As Boolean

' Simulation de l'événement standard KeyDown
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  lblFocus.Caption = "KeyDown " & KeyCode & " " & Shift
End Sub

' Simulation de l'événement standard KeyPress
Private Sub UserControl_KeyPress(KeyAscii As Integer)
  lblFocus.Caption = "KeyPress " & KeyAscii
End Sub

' Simulation de l'événement standard KeyUp
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  lblFocus.Caption = "KeyUp " & KeyCode & " " & Shift
End Sub

' Renvoie ou définit si le contrôle intercepte la touche Tabulation
Public Property Get InterceptTab() As Boolean
  InterceptTab = mInterceptTab
End Property

Public Property Let InterceptTab(ByVal New_InterceptTab As Boolean)
  mInterceptTab = New_InterceptTab
End Property

' Renvoie l'état actuel d'une touche
Private Function KeyState(ByVal KeyCode As KeyCodeConstants) As Boolean
  KeyState = ((GetKeyState(KeyCode) And &H8000&) = &H8000&)
End Function

' Renvoie l'état des touches Shift, Control et Alt dans le format standard Visual Basic
Private Function ShiftState() As Integer
  ShiftState = (-vbShiftMask * KeyState(VK_SHIFT)) Or (-vbCtrlMask * KeyState(VK_CONTROL)) Or (-vbAltMask * KeyState(VK_MENU))
End Function

' A la réception du Focus
Private Sub UserControl_GotFocus()
  lblFocus.Caption = "Focus"
End Sub

' A la perte du Foucs
Private Sub UserControl_LostFocus()
  lblFocus.Caption = "Not in Focus"
End Sub

' Implémentation de IInPlaceActiveObject_TranslateAccelerator
Private Function IInPlaceActiveObject_TranslateAccelerator _
(ByVal hwnd As Long, _
  ByVal Msg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long, _
  ByVal x As Long, _
  ByVal y As Long, _
  ByVal Time As Long) As Long

  IInPlaceActiveObject_TranslateAccelerator = S_FALSE
  If mInterceptTab Then
    If CInt(wParam And &H7FFF&) = vbKeyTab Then
      Select Case Msg
        Case WM_KEYDOWN: UserControl_KeyDown vbKeyTab, ShiftState
        Case WM_KEYUP: UserControl_KeyUp vbKeyTab, ShiftState
      End Select
      IInPlaceActiveObject_TranslateAccelerator = S_OK
    End If
  End If

End Function

' Implementation de ISublass_MessageResponse
Private Property Get ISubclass_MessageResponse() As ISubClassMessageResponse
  ISubclass_MessageResponse = scMsgPreprocess
End Property

' Implementation de ISublass_WindowProc
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Interception du message WM_SETFOCUS et Activation de l'interface InPlaceActiveObject
  Select Case iMsg
   Case WM_SETFOCUS:
     If mInterceptTab Then InPlaceActiveObjectSubclass Me, UserControl.hwnd
  End Select
End Function

' Lecture des propriétés
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  If Ambient.UserMode Then
    AttachMessage Me, UserControl.hwnd, WM_SETFOCUS
    InPlaceActiveObjectAttach Me, UserControl.hwnd
  End If
End Sub

' Terminaison du contrôle
Private Sub UserControl_Terminate()
  DetachMessage Me, UserControl.hwnd, WM_SETFOCUS
  InPlaceActiveObjectDetach UserControl.hwnd
End Sub

Fenêtre wndMain

Option Explicit

Private Sub chkTabStops_Click()
  Dim ctl As Control
  For Each ctl In Controls
     If TypeOf ctl Is IPAO Then
     Else
        On Error Resume Next
        ctl.TabStop = (chkTabStops.Value = Checked)
     End If
  Next ctl
End Sub

Private Sub cmdExit_Click()
  Unload Me
End Sub

Private Sub chkControlGetsTabs_Click()
  ctl.InterceptTab = (chkInterceptTab.Value = Checked)
End Sub

Private Sub Form_Load()
  ctl.InterceptTab = (chkInterceptTab.Value = Checked)
End Sub