Miscellaneous mouse and keyboard routines in Visual Basic 6.0

Visual Basic has keywords to represent any command which can be keyed manually into the computer, and, thus, practically any routine procedure can be represented in code in the Visual Basic editor.
The full set of keywords can be found by clicking View | Object Browser, which is a library of the whole Word object model.
In programming terms, everything on screen from the complete Word program through it’s various menu options down to a full stop is an ‘object’ which has various properties and methods, each of which can be manipulated by using Visual Basic code.
This means that, past this trivial example, Visual Basic can be used to program in a highly customised way everything from writing some text onto the page to opening entirely new documents or document templates, writing text to them from customised dialog boxes and printing a specified number of copies from specified printer-trays.


Option Explicit

' MouseKeyboard version 1.1 by Lord Orwell

' ----------------------------
' Constants & API Declarations
' ----------------------------

' this sub contains all of the mouse and keyboard subs.
Public Const KEYEVENTF_KEYUP = &H2
Private Const SPI_SCREENSAVERRUNNING = 97&
Declare Function CharToOem& Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String)
Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
'Declare Function GetKeyboardState& Lib "user32" (pbKeyState As String)
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Declare Function OemKeyScan& Lib "user32" (ByVal wOemChar As Integer)
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Declare Function VkKeyScan% Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte)


' -----------
' Functions
' -----------

Sub ShowMouseCursor()
Dim rtn As Long
rtn = ShowCursor(True)
End Sub

Sub HideMouseCursor()
Dim rtn As Long
rtn = ShowCursor(False)
End Sub

Sub DisableTaskKeys()
'disables ctrl-alt-del, alt-tab, ctrl-f4, etc., keeping you in charge...
Dim rtn As Long
rtn = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1&, 0&, 0)
End Sub

Sub EnableTaskKeys()
Dim rtn As Long
rtn = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0&, 0&, 0)
End Sub

Function ScanCodeToAscii(ScanCode As Long) As Long
ScanCodeToAscii = MapVirtualKey(ScanCode, 2)
End Function

Function WasKeyPressed(VBKey As Long)
Dim ScanCode As Integer
ScanCode = GetKeyState(VBKey)
If ScanCode And &HFFF0 > 0 Then
WasKeyPressed = True
Else
WasKeyPressed = False
End If
End Function

Function IsKeyPressed(VBKey As Long) As Boolean
Dim KeyState As Integer
KeyState = GetAsyncKeyState(VBKey)

If KeyState And &H8000 = &H8000 Then
IsKeyPressed = True ' : Debug.Print VBKey
Else
IsKeyPressed = False
End If
End Function

Function IsAsciiKeyPressed(Ascii As Integer) As Boolean
'
End Function

Public Sub TypeAsciiKey(ByVal Char As Integer, AllStates As Integer)
Dim c As String
Dim vk%
Dim Scan%
Dim OemChar$
' Dim dl&
Dim ShiftState As Integer
' Dim ss As Long
Dim CtrlState As Integer
Dim AltState As Integer
Dim ShiftScanCode As Integer
Dim CtrlScanCode As Integer
Dim AltScanCode As Integer
ShiftScanCode = MapVirtualKey(vbKeyShift, 0)
CtrlScanCode = MapVirtualKey(vbKeyControl, 0)
AltScanCode = MapVirtualKey(vbKeyMenu, 0)
c = ChrW$(Char)
'ss = (VkKeyScan(AscW(c$)) And &H100) / &HFF
' MsgBox ss
' Get the virtual key code for this character
vk% = VkKeyScan(Char) And &HFF
If AllStates = 0 Then AllStates = (VkKeyScan(AscW(c$)) And &H100) / &HFF
ShiftState = AllStates And 1
CtrlState = (AllStates And 2) / 2
AltState = (AllStates And 4) / 4
OemChar$ = " " ' 2 character buffer
' Get the OEM character - preinitialize the buffer
CharToOem left$(c$, 1), OemChar$
' Get the scan code for this key
Scan% = OemKeyScan(AscW(OemChar$)) And &HFF
If ShiftState = 1 Then
keybd_event vbKeyShift, ShiftScanCode, 0, 0
DoEvents
End If
If CtrlState = 1 Then
keybd_event vbKeyControl, CtrlScanCode, 0, 0
DoEvents
End If
If AltState = 1 Then
keybd_event vbKeyMenu, AltScanCode, 0, 0
DoEvents
End If
' Send the key down
keybd_event vk%, Scan%, 0, 0
DoEvents
' Send the key up
keybd_event vk%, Scan%, KEYEVENTF_KEYUP, 0
DoEvents
If ShiftState = 1 Then
keybd_event vbKeyShift, ShiftScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
If CtrlState = 1 Then
keybd_event vbKeyControl, CtrlScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
If AltState = 1 Then
keybd_event vbKeyMenu, AltScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
End Sub

Sub TypeKey(KeyToType As String, ToggleKeys As Integer)
'togglekeys: bit1 = shift, 2 = ctrl, 3 = alt.
Call TypeAsciiKey(AscW(KeyToType), ToggleKeys)
End Sub

Sub MySendKeys(StringToType As String)
' MsgBox StringToType
'doesn't work exactly like the vb version.
'to send a shifted character, simply type it.
'it will be converted automatically. There are
'three exceptions: ~^%{. Each of these keys has to
'be typed 2 times in a row. They are used to toggle
'on shift, ctrl, and/or alt states of the keyboard
'for the next character typed.
'special codes: + = shift, ^ = ctrl, % = alt
'a * after the ' means it is implemented, otherwise
' it is slated for future implementation
'*BACKSPACE {BACKSPACE}, {BS}, or {BKSP}
'*BREAK {BREAK}
'*CAPS LOCK {CAPSLOCK}
'*DEL or DELETE {DELETE} or {DEL}
'*DOWN ARROW {DOWN}
'*END {END}
'*ENTER {ENTER}or ~
'*ESC {ESC}
' HELP {HELP}
' HOME {HOME}
'*INS or INSERT {INSERT} or {INS}
'*LEFT ARROW {LEFT}
' NUM LOCK {NUMLOCK}
' PAGE DOWN {PGDN}
' PAGE UP {PGUP}
'*PRINT SCREEN {PRTSC}
'*RIGHT ARROW {RIGHT}
' SCROLL LOCK {SCROLLLOCK}
'*TAB {TAB}
'*UP ARROW {UP}
' F1 {F1}
' F2 {F2}
' F3 {F3}
' F4 {F4}
' F5 {F5}
' F6 {F6}
' F7 {F7}
' F8 {F8}
' F9 {F9}
' F10 {F10}
' F11 {F11}
' F12 {F12}
' F13 {F13}
' F14 {F14}
' F15 {F15}
' F16 {F16}
' Dim LcaseStringToType As String
Dim ToggleKeys As Integer
Dim Char As String
ToggleKeys = 0
Dim cl As Long
cl = 1
Do While cl <= Len(StringToType)
ToggleKeys = 0
' LcaseStringToType = LCase$(StringToType)
Do While Char = "%" Or Char = "^" Or Char = "+" Or Char = "{" Or Char = "~"
Char = Mid$(StringToType, cl, 1)
If Char = "{" Then
cl = cl + 1
If Mid$(StringToType, cl - 1, 2) = "{{" Then
cl = cl + 1
Call TypeKey(Char, 0)
Else
If StrComp(Mid$(StringToType, cl, 10), "backspace}", vbTextCompare) = 0 Then
cl = cl + 10
VirtualKeyPress vbKeyBack
ElseIf StrComp(Mid$(StringToType, cl, 3), "bs}", vbTextCompare) = 0 Then
cl = cl + 3
VirtualKeyPress vbKeyBack
ElseIf StrComp(Mid$(StringToType, cl, 5), "bksp}", vbTextCompare) = 0 Then
cl = cl + 5
VirtualKeyPress vbKeyBack
ElseIf StrComp(Mid$(StringToType, cl, 7), "delete}", vbTextCompare) = 0 Then
cl = cl + 7
VirtualKeyPress vbKeyDelete
ElseIf StrComp(Mid$(StringToType, cl, 4), "del}", vbTextCompare) = 0 Then
cl = cl + 4
VirtualKeyPress vbKeyDelete
ElseIf StrComp(Mid$(StringToType, cl, 5), "home}", vbTextCompare) = 0 Then
cl = cl + 5
VirtualKeyPress vbKeyHome
ElseIf StrComp(Mid$(StringToType, cl, 6), "enter}", vbTextCompare) = 0 Then
cl = cl + 6
VirtualKeyPress vbKeyReturn
ElseIf StrComp(Mid$(StringToType, cl, 4), "tab}", vbTextCompare) = 0 Then
cl = cl + 4
VirtualKeyPress vbKeyTab
ElseIf StrComp(Mid$(StringToType, cl, 6), "prtsc}", vbTextCompare) = 0 Then
cl = cl + 6
VirtualKeyPress vbKeySnapshot
ElseIf StrComp(Mid$(StringToType, cl, 4), "end}", vbTextCompare) = 0 Then
cl = cl + 4
VirtualKeyPress vbKeyEnd
ElseIf StrComp(Mid$(StringToType, cl, 4), "ins}", vbTextCompare) = 0 Then
cl = cl + 4
VirtualKeyPress vbKeyInsert
ElseIf StrComp(Mid$(StringToType, cl, 7), "insert}", vbTextCompare) = 0 Then
cl = cl + 7
VirtualKeyPress vbKeyInsert
ElseIf StrComp(Mid$(StringToType, cl, 5), "left}", vbTextCompare) = 0 Then
cl = cl + 5
VirtualKeyPress vbKeyLeft
ElseIf StrComp(Mid$(StringToType, cl, 6), "right}", vbTextCompare) = 0 Then
cl = cl + 6
VirtualKeyPress vbKeyRight
ElseIf StrComp(Mid$(StringToType, cl, 6), "break}", vbTextCompare) = 0 Then
cl = cl + 6
VirtualKeyPress vbKeyPause
ElseIf StrComp(Mid$(StringToType, cl, 9), "capslock}", vbTextCompare) = 0 Then
cl = cl + 9
VirtualKeyPress vbKeyCapital
ElseIf StrComp(Mid$(StringToType, cl, 10), "downarrow}", vbTextCompare) = 0 Then
cl = cl + 10
VirtualKeyPress vbKeyDown
ElseIf StrComp(Mid$(StringToType, cl, 8), "uparrow}", vbTextCompare) = 0 Then
cl = cl + 8
VirtualKeyPress vbKeyUp
ElseIf StrComp(Mid$(StringToType, cl, 4), "esc}", vbTextCompare) = 0 Then
cl = cl + 4
VirtualKeyPress vbKeyEscape
End If
End If
ElseIf Char = "~" Then
cl = cl + 1
If Mid$(StringToType, cl, 1) = "~" Then
cl = cl + 1
Call TypeKey(Char, 0)
Else
VirtualKeyPress vbKeyReturn
End If
ElseIf Char = "+" Then
cl = cl + 1
If Mid$(StringToType, cl, 1) = "+" Then
cl = cl + 1
Call TypeKey(Char, 0)
Else
ToggleKeys = ToggleKeys + 1
End If
ElseIf Char = "^" Then
cl = cl + 1
If Mid$(StringToType, cl - 1, 2) = "^^" Then
cl = cl + 1
Call TypeKey(Char, 0)
Else
ToggleKeys = ToggleKeys + 2
End If
ElseIf Char = "%" Then
cl = cl + 1
If Mid$(StringToType, cl - 1, 2) = "%%" Then
cl = cl + 1
Call TypeKey(Char, 0)
Else
ToggleKeys = ToggleKeys + 4
End If
End If
Loop
' Debug.Print Char, ToggleKeys
If Len(Char) <> 0 Then Call TypeKey(Char, ToggleKeys)
Loop
End Sub

Sub VirtualKeyPress(VirtualKeyCode As Integer)
Dim ScanCode As Integer
ScanCode = MapVirtualKey(VirtualKeyCode, 0)
keybd_event VirtualKeyCode%, ScanCode, 0, 0
DoEvents
keybd_event VirtualKeyCode, ScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End Sub

Public Sub VirtualKeyPressEx(VirtualKeyCode As Integer, Shift As Integer, Ctrl As Integer, Alt As Integer)
Dim ShiftScanCode As Integer
Dim CtrlScanCode As Integer
Dim AltScanCode As Integer

ShiftScanCode = MapVirtualKey(vbKeyShift, 0)
CtrlScanCode = MapVirtualKey(vbKeyControl, 0)
AltScanCode = MapVirtualKey(vbKeyMenu, 0)

' Get the virtual key code for this character
Dim ScanCode As Integer
ScanCode = MapVirtualKey(VirtualKeyCode, 0)

' Shift = AllStates And 1
' Ctrl = (AllStates And 2) / 2
' Alt = (AllStates And 4) / 4

If Ctrl = 1 Then
keybd_event vbKeyControl, CtrlScanCode, 0, 0
DoEvents
End If
If Shift = 1 Then
keybd_event vbKeyShift, ShiftScanCode, 0, 0
DoEvents
End If
If Alt = 1 Then
keybd_event vbKeyMenu, AltScanCode, 0, 0
DoEvents
End If

' Send the key down
keybd_event VirtualKeyCode%, ScanCode, 0, 0
DoEvents
' Send the key up
keybd_event VirtualKeyCode, ScanCode, KEYEVENTF_KEYUP, 0
DoEvents

If Shift = 1 Then
keybd_event vbKeyShift, ShiftScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
If Ctrl = 1 Then
keybd_event vbKeyControl, CtrlScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
If Alt = 1 Then
keybd_event vbKeyMenu, AltScanCode, KEYEVENTF_KEYUP, 0
DoEvents
End If
End Sub



Related Posts by Categories



Widget by Hoctro

Enter your email address:

Delivered by FeedBurner

Followers



Source Code