vbAccelerator - Contents of code file: frmTestAppCommands.frm

VERSION 5.00
Begin VB.Form frmTestAppCommands 
   Caption         =   "vbAccelerator AppCommand Class Demonstration"
   ClientHeight    =   7050
   ClientLeft      =   4590
   ClientTop       =   1980
   ClientWidth     =   6360
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTestAppCommands.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7050
   ScaleWidth      =   6360
   Begin VB.ListBox lstEvents 
      Height          =   1425
      Left            =   120
      TabIndex        =   5
      Top             =   5520
      Width           =   6075
   End
   Begin VB.ListBox lstOptions 
      Height          =   3210
      Left            =   120
      Style           =   1  'Checkbox
      TabIndex        =   0
      Top             =   840
      Width           =   6075
   End
   Begin VB.Label lblEvents 
      BackColor       =   &H80000010&
      Caption         =   " Events"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000016&
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   5160
      Width           =   6075
   End
   Begin VB.Label lblConfigure 
      BackColor       =   &H80000010&
      Caption         =   " Configure"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000016&
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   60
      Width           =   6075
   End
   Begin VB.Label lblDescription 
      Height          =   555
      Left            =   120
      TabIndex        =   2
      Top             =   4140
      Width           =   6015
   End
   Begin VB.Label lblInfo 
      Caption         =   $"frmTestAppCommands.frx":1272
      Height          =   495
      Left            =   120
      TabIndex        =   1
      Top             =   360
      Width           =   6075
   End
End
Attribute VB_Name = "frmTestAppCommands"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private WithEvents m_cAppCommand As cAppCommand
Attribute m_cAppCommand.VB_VarHelpID = -1
Private m_domAPI As DOMDocument

Private Sub Form_Load()
   
   ' Create the class for intercepting
   ' app command events:
   Set m_cAppCommand = New cAppCommand
   m_cAppCommand.Attach Me.hWnd
   
   ' Load the XML document which contains
   ' details of the API so we can display
   ' the info whenever an event occurs
   ' and also provide a UI for saying
   ' which events we want to consume.
   Set m_domAPI = New DOMDocument
   Dim sApiXMLFile As String
   sApiXMLFile = normalizePath(App.path) & "/home/VB/Tips/Responding_to_AppCommands/AppCommandApi.xml"
   If m_domAPI.Load(sApiXMLFile) Then
      displayOptions
   Else
      MsgBox "The file " & sApiXMLFile & " was not found or is corrupt: [" &
       m_domAPI.parseError & "]", vbExclamation
   End If
   
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   ' clear up (will be done automatically by
   ' VB, but anyway)
   Set m_cAppCommand = Nothing
End Sub

Private Sub lstOptions_Click()
   '
   Dim nodCommand As IXMLDOMNode
   Set nodCommand = getCommandNode(lstOptions.ItemData(lstOptions.ListIndex))
   lblDescription.Caption =
    nodCommand.selectSingleNode("Description").childNodes(0).nodeValue
   '
End Sub

Private Sub m_cAppCommand_AppCommand(ByVal command As AppCommandConstants,
 ByVal fromDevice As AppCommandDeviceConstants, ByVal keyState As
 AppCommandKeyStateConstants, ByRef processed As Boolean)
   '
   Dim sMsg As String
   
   Dim nodCommand As IXMLDOMNode
   Set nodCommand = getCommandNode(command)
   If Not (nodCommand Is Nothing) Then
      ' built-in command:
      sMsg = nodCommand.selectSingleNode("Description").childNodes(0).nodeValue
   Else
      ' custom command:
      sMsg = "Custom Command (value=" & command & ")"
   End If
   
   Dim nodFromDevice As IXMLDOMNode
   Set nodFromDevice = getDeviceNode(fromDevice)
   sMsg = sMsg & "From " &
    nodFromDevice.selectSingleNode("Description").childNodes(0).nodeValue
   
   sMsg = sMsg & ", Keys:" & keysPressedDescription(keyState)
   
   ' Determine whether to pass on to Windows or not:
   processed = processCommand(command)
   
   lstEvents.AddItem sMsg
   
   '
End Sub

Private Function keysPressedDescription(ByVal keyState As
 AppCommandKeyStateConstants) As String
Dim sMsg As String
Dim flag As Long
   flag = 1
   Do While (flag <= 64)
      If (keyState And flag) = flag Then
         If (Len(sMsg) > 1) Then
            sMsg = sMsg & ", "
         End If
         sMsg = sMsg &
          getKeyStateNode(flag).selectSingleNode("Description").childNodes(0).no
         deValue
      End If
      flag = flag * 2
   Loop
   keysPressedDescription = sMsg
End Function

Private Function processCommand(ByVal command As Long) As Boolean
Dim i As Long
   For i = 0 To lstOptions.ListCount
      If (lstOptions.ItemData(i) = command) Then
         processCommand = lstOptions.Selected(i)
         Exit For
      End If
   Next i
End Function

' Show the list of app commands from the file
Private Sub displayOptions()
Dim nodCommand As IXMLDOMNode
   For Each nodCommand In
    m_domAPI.selectNodes("AppCommandApi/CommandList/Command")
      lstOptions.AddItem
       nodCommand.selectSingleNode("Name").childNodes(0).nodeValue
      lstOptions.ItemData(lstOptions.NewIndex) =
       CLng(attributeValue(nodCommand, "value"))
   Next
End Sub

' Return the KeyState node for the specified KeyState value:
Private Function getKeyStateNode(ByVal value As Long) As IXMLDOMNode
   Dim xPath As String
   xPath = "AppCommandApi/KeyStateList/KeyState[@value='" & value & "']"
   Set getKeyStateNode = m_domAPI.selectSingleNode(xPath)
End Function

' Return the KeyState node for the specified KeyState value:
Private Function getDeviceNode(ByVal value As Long) As IXMLDOMNode
   Dim xPath As String
   xPath = "AppCommandApi/DeviceTypeList/DeviceType[@value='" & value & "']"
   Set getDeviceNode = m_domAPI.selectSingleNode(xPath)
End Function

' Return the command node for the specified app command value:
Private Function getCommandNode(ByVal value As Long) As IXMLDOMNode
   Dim xPath As String
   xPath = "AppCommandApi/CommandList/Command[@value='" & value & "']"
   Set getCommandNode = m_domAPI.selectSingleNode(xPath)
End Function

' helper function: add a path separator to the end of a path if it doesn't have
 one
Private Function normalizePath(ByVal path As String) As String
   If Not (Right$(Trim$(path), 1) = "\") Then
      normalizePath = path & "\"
   Else
      normalizePath = path
   End If
   
End Function

' helper function: return the value of the attribute with the specified name:
Private Function attributeValue(ByVal nod As IXMLDOMNode, ByVal name As String)
 As String
Dim attr As IXMLDOMAttribute
   For Each attr In nod.Attributes
      If StrComp(attr.name, name) = 0 Then
         attributeValue = attr.value
         Exit For
      End If
   Next
End Function