Code:
'--------- Class Name: clsKeys
Option Explicit
Private Declare Function MapVirtualKey Lib "user32" Alias _
"MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Private Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal _
cChar As Byte) As Integer
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As _
Long) As Integer
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Public Enum enumKeys
keyBackspace = &H8
keyTab = &H9
keyReturn = &HD
keyShift = &H10
keyControl = &H11
keyAlt = &H12
keyPause = &H13
keyEscape = &H1B
keySpace = &H20
keyPageUp = &H21
keyPageDown = &H22
keyEnd = &H23
keyHome = &H24
keyLeft = &H25
KeyUp = &H26
keyRight = &H27
KeyDown = &H28
keyInsert = &H2D
keyDelete = &H2E
keyF1 = &H70
keyF2 = &H71
keyF3 = &H72
keyF4 = &H73
keyF5 = &H74
keyF6 = &H75
keyF7 = &H76
keyF8 = &H77
keyF9 = &H78
keyF10 = &H79
keyF11 = &H7A
keyF12 = &H7B
keyNumLock = &H90
keyScrollLock = &H91
keyCapsLock = &H14
End Enum
'Presses the single key represented by sKey
Public Sub PressKey(sKey As String, Optional bHold As Boolean, Optional _
bRelease As Boolean)
Dim nVK As Long
nVK = VkKeyScan(Asc(sKey))
If nVK = 0 Then
Exit Sub
End If
Dim nScan As Long
Dim nExtended As Long
nScan = MapVirtualKey(nVK, 2)
nExtended = 0
If nScan = 0 Then
nExtended = KEYEVENTF_EXTENDEDKEY
End If
nScan = MapVirtualKey(nVK, 0)
Dim bShift As Boolean
Dim bCtrl As Boolean
Dim bAlt As Boolean
bShift = (nVK And &H100)
bCtrl = (nVK And &H200)
bAlt = (nVK And &H400)
nVK = (nVK And &HFF)
If Not bRelease Then
If bShift Then
keybd_event enumKeys.keyShift, 0, 0, 0
End If
If bCtrl Then
keybd_event enumKeys.keyControl, 0, 0, 0
End If
If bAlt Then
keybd_event enumKeys.keyAlt, 0, 0, 0
End If
keybd_event nVK, nScan, nExtended, 0
End If
If Not bHold Then
keybd_event nVK, nScan, KEYEVENTF_KEYUP Or nExtended, 0
If bShift Then
keybd_event enumKeys.keyShift, 0, KEYEVENTF_KEYUP, 0
End If
If bCtrl Then
keybd_event enumKeys.keyControl, 0, KEYEVENTF_KEYUP, 0
End If
If bAlt Then
keybd_event enumKeys.keyAlt, 0, KEYEVENTF_KEYUP, 0
End If
End If
End Sub
'Loop through a string and calls PressKey for each character (Does not
' parse strings like SendKeys)
Public Sub PressString(ByVal sString As String, _
Optional bDoEvents As Boolean = True)
Do While sString <> ""
PressKey Mid(sString, 1, 1)
Sleep 20
If bDoEvents Then
DoEvents
End If
sString = Mid(sString, 2)
Loop
End Sub
'Presses a specific key (this is used for keys that don't have a
' ascii equilivant)
Public Sub PressKeyVK(keyPress As enumKeys, Optional bHold As Boolean, _
Optional bRelease As Boolean, Optional bCompatible As Boolean)
Dim nScan As Long
Dim nExtended As Long
nScan = MapVirtualKey(keyPress, 2)
nExtended = 0
If nScan = 0 Then
nExtended = KEYEVENTF_EXTENDEDKEY
End If
nScan = MapVirtualKey(keyPress, 0)
If bCompatible Then
nExtended = 0
End If
If Not bRelease Then
keybd_event keyPress, nScan, nExtended, 0
End If
If Not bHold Then
keybd_event keyPress, nScan, KEYEVENTF_KEYUP Or nExtended, 0
End If
End Sub
'Returns (in the boolean variables) the status of the various Lock keys
Public Sub GetLockStatus(bCapsLock As Boolean, bNumLock As Boolean, _
bScrollLock As Boolean)
bCapsLock = GetKeyState(enumKeys.keyCapsLock)
bNumLock = GetKeyState(enumKeys.keyNumLock)
bScrollLock = GetKeyState(enumKeys.keyScrollLock)
End Sub
'Presses a sequence of keys, attempts to parse strings like
'SendKeys() does.
Public Sub PressSendKeys(ByVal sKeys As String)
Dim nPos As Long
Dim sPart As String
Dim colModify As Collection: Set colModify = New Collection
Dim bBrace As Boolean
Dim i As Long
Dim nCount As Long
Dim nVK As Long
nPos = 1
Do While nPos <= Len(sKeys)
Select Case UCase(Mid(sKeys, nPos, 1))
Case "+", "^", "%"
If Mid(sKeys, nPos, 1) = "+" Then
nVK = keyShift
ElseIf Mid(sKeys, nPos, 1) = "^" Then
nVK = keyControl
Else 'Mid(sKeys, nPos, 1) = "%" then
nVK = keyAlt
End If
PressKeyVK nVK, True
colModify.Add nVK
If Mid(sKeys, nPos + 1, 1) <> "(" And Mid(sKeys, _
nPos + 1, 1) <> "{" Then
sKeys = Mid(sKeys, 1, nPos) & "(" & Mid(sKeys, _
nPos + 1, 1) & ")" & Mid(sKeys, nPos + 2)
End If
Case "~" 'enter
PressKeyVK keyReturn
Case "("
'do nothing
Case ")", "}"
If colModify.Count > 0 Then
If colModify.Item(colModify.Count) <> 0 Then
PressKeyVK colModify.Item(colModify.Count) _
, , True
End If
colModify.Remove colModify.Count
End If
Case "{" 'Brace
colModify.Add 0
nCount = 0
FindSpecial nPos, sKeys, sPart, nCount, nVK
If Mid(sKeys, nPos, 1) = " " Then
nCount = 0
Do Until Mid(sKeys, nPos, 1) = "}" Or _
nPos > Len(sKeys)
nCount = (nCount * 10) + _
Val(Mid(sKeys, nPos, 1))
nPos = nPos + 1
Loop
Else
nCount = 1
End If
For i = 1 To nCount
If nVK = 0 Then
PressKey sPart
Else
PressKeyVK nVK
DoEvents
End If
Next
nPos = nPos - 1
Case Else
PressKey Mid(sKeys, nPos, 1)
End Select
DoEvents
nPos = nPos + 1
Loop
End Sub
Private Sub FindSpecial(nPos As Long, sKeys As String, _
sPart As String, nCount As Long, nVK As Long)
Dim bFound As Boolean
nCount = 1
nVK = 0
sPart = ""
nPos = nPos + 1
bFound = True
Select Case UCase(Mid(sKeys, nPos, 2))
Case "BS": nVK = keyBackspace
Case "UP": nVK = KeyUp
Case "F1": nVK = keyF1
Case "F2": nVK = keyF2
Case "F3": nVK = keyF3
Case "F4": nVK = keyF4
Case "F5": nVK = keyF5
Case "F6": nVK = keyF6
Case "F7": nVK = keyF7
Case "F8": nVK = keyF8
Case "F9": nVK = keyF9
Case Else
bFound = False
End Select
If bFound Then
nPos = nPos + 2
Exit Sub
End If
bFound = True
Select Case UCase(Mid(sKeys, nPos, 3))
Case "F10": nVK = keyF10
Case "F11": nVK = keyF11
Case "F12": nVK = keyF12
Case "DEL": nVK = keyDelete
Case "END": nVK = enumKeys.keyEnd
Case "ESC": nVK = enumKeys.keyEscape
Case "INS": nVK = enumKeys.keyInsert
Case "TAB": nVK = enumKeys.keyTab
Case Else
bFound = False
End Select
If bFound Then
nPos = nPos + 3
Exit Sub
End If
bFound = True
Select Case UCase(Mid(sKeys, nPos, 4))
Case "BKSP": nVK = enumKeys.keyBackspace
Case "DOWN": nVK = enumKeys.KeyDown
Case "HOME": nVK = enumKeys.keyHome
Case "LEFT": nVK = enumKeys.keyLeft
Case "PGDN": nVK = enumKeys.keyPageDown
Case "PGUP": nVK = enumKeys.keyPageUp
Case Else
bFound = False
End Select
If bFound Then
nPos = nPos + 4
Exit Sub
End If
bFound = True
Select Case UCase(Mid(sKeys, nPos, 5))
Case "ENTER": nVK = enumKeys.keyReturn
Case "RIGHT": nVK = enumKeys.keyRight
Case Else
bFound = False
End Select
If bFound Then
nPos = nPos + 5
Exit Sub
End If
bFound = True
Select Case UCase(Mid(sKeys, nPos, 6))
Case "DELETE": nVK = enumKeys.keyInsert
Case "INSERT": nVK = enumKeys.keyDelete
Case Else
bFound = False
End Select
If bFound Then
nPos = nPos + 6
Exit Sub
End If
If UCase(Mid(sKeys, nPos, 7)) = "NUMLOCK" Then
nVK = enumKeys.keyNumLock
nPos = nPos + 7
Exit Sub
End If
If UCase(Mid(sKeys, nPos, 8)) = "CAPSLOCK" Then
nVK = enumKeys.keyCapsLock
nPos = nPos + 8
Exit Sub
End If
If UCase(Mid(sKeys, nPos, 9)) = "BACKSPACE" Then
nVK = enumKeys.keyBackspace
nPos = nPos + 9
Exit Sub
End If
If UCase(Mid(sKeys, nPos, 10)) = "SCROLLLOCK" Then
nVK = enumKeys.keyScrollLock
nPos = nPos + 10
Exit Sub
End If
nVK = 0
sPart = Mid(sKeys, nPos, 1)
nPos = nPos + 1
End Sub
'--------- End of class: clsKeys
'Form1 with timer
Timer1_Timer()
Dim keys As New clsKeys
keys.PressKeyVK vbKeyF 'Show Friend list
End Sub