vha. noget kode Sjh herinde har lavet:
http://vbhansen.dk/spm/505035/vbKeyboard.ziphttp://vbhansen.dk/spm/538986/MouseHookPos.zipKan du optage keys+mouse events, herefter afspille dem vha. AutoItX.
Flg. kode er baseret på Sjh's kode,
den består af modulerne frmMain (redigeret), modKeyboard.bas (ej redigeret) og modMouseHook.bas (redigeret).
Lav 3 commandButtons command1, command2 og cammand3
indsæt flg. kode i frmMain.frm
**** frmMain.frm code ****
Option Explicit
Dim KeysLogged As String
Dim MouseX As Integer
Dim MouseY As Integer
Public Sub HookKeyDown(KeyCode As Integer, Shift As Integer)
Select Case Shift
Case 1 'SHIFT
KeysLogged = KeysLogged & "event-key+" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "shift+" & KeyGen(KeyCode)
Case 2 'CTRL
KeysLogged = KeysLogged & "event-key^" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "ctrl+" & KeyGen(KeyCode)
Case 3 'SHIFT + CTRL
KeysLogged = KeysLogged & "event-key^+" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "ctrl+shift+" & KeyGen(KeyCode)
Case 4 'ALT
KeysLogged = KeysLogged & "event-key!" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "alt+" & KeyGen(KeyCode)
Case 5 'ALT + SHIFT
KeysLogged = KeysLogged & "event-key!" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "alt+shift+" & KeyGen(KeyCode)
Case 6 'ALT + CTRL
KeysLogged = KeysLogged & "event-key!" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "ctrl+alt+" & KeyGen(KeyCode)
Case 7 'ALT + SHIFT + CTRL
KeysLogged = KeysLogged & "event-key!" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & "ctrl+alt+shift+" & KeyGen(KeyCode)
Case Else
KeysLogged = KeysLogged & "event-key+" & KeyGen(KeyCode)
lstKey.AddItem "Keyboard: " & KeyGen(KeyCode)
End Select
End Sub
Private Sub Command1_Click()
lstKey.Clear
Call HookKeyboard(Me) '** starter optagelsen
Call SetMouseHook(Me)
KeysLogged = ""
End Sub
Private Sub Command2_Click()
Call UnHookKeyboard '** slukker for optagelsen
Call UnMouseHook
'** afspiller 'macroen' (AutoItX)
Dim w, i
Dim oAutoIt
Set oAutoIt = CreateObject("AutoItX3.Control")
MsgBox "tryk når du er klar"
w = Split(KeysLogged, "event-")
For i = 0 To UBound(w)
Debug.Print "'" & w(i) & "'"
Select Case Left(w(i), 3)
Case "mus":
oAutoIt.MouseClick GetMouseEventInfo(w(i), 3), GetMouseEventInfo(w(i), 1), GetMouseEventInfo(w(i), 2)
Case "key":
oAutoIt.Send Right(w(i), Len(w(i)) - 3)
Case Else: MsgBox "'" & w(i) & "' er en fejl!", vbCritical, "Fejl"
End Select
Next
MsgBox "slut!"
End Sub
Function GetMouseEventInfo(saved_data, nr As Integer)
Dim e
e = Split(saved_data, ":")
GetMouseEventInfo = e(nr)
End Function
Private Sub Command3_Click()
KeysLogged = "" '** starter på ny optagelse
Call HookKeyboard(Me) '** starter optagelsen
Call SetMouseHook(Me)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call UnHookKeyboard '** slukker for optagelsen
Call UnMouseHook
End Sub
Public Sub API_MouseMove(X As Long, Y As Long)
MouseX = X
MouseY = Y
End Sub
Public Sub API_MouseEvent(button As String)
KeysLogged = KeysLogged & "event-mus:" & MouseX & ":" & MouseY & ":" & button
lstKey.AddItem "Mouse: " & "X:" & MouseX & " Y:" & MouseY & " " & button
End Sub
Function KeyGen(KeyAsciiCode As Integer)
Dim q As String
q = Chr(KeyAsciiCode)
If q = "!" _
Or q = "#" _
Or q = "+" _
Or q = "^" _
Or q = "{" _
Or q = "}" _
Or q = " " _
Or q = vbCrLf _
Or q = vbCr _
Or q = vbLf Then
q = "{" & q & "}"
End If
KeyGen = q
'** denne funktion forhindre misforståelserne der opstår ved
'** at tegnene som ! ^ + osv. har betydninger som alt, control og shift, når de bruges med AutoItX
End Function
**** frmMain.frm code end ****
**** ModKeyboard.frm code ****
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function GetKeyState Lib "user32" ( _
ByVal nVirtKey As Long) As Integer
Private Const HC_ACTION As Long = 0
Private Const WH_KEYBOARD_LL As Long = 13
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
Flags As Long
Time As Long
dwExtraInfo As Long
End Type
Private objForm As Form
Private hkKeyboard As Long
Private KHS As KBDLLHOOKSTRUCT
Private Function KeyboardProc(ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If nCode = HC_ACTION Then
Call CopyMemory(KHS, ByVal lParam, Len(KHS))
With KHS
Select Case .Flags
Case 0, 1, 32, 33, 128
Dim mShift As Integer
If (GetKeyState(vbKeyShift) And &HF0000000) Then
mShift = 1 'Shift
End If
If (GetKeyState(vbKeyControl) And &HF0000000) Then
mShift = (mShift + 2) 'Ctrl
End If
If (GetKeyState(vbKeyMenu) And &HF0000000) Then
mShift = (mShift + 4) 'Alt og AltGr
End If
'De 128 bruges af Alt og AltGr. og skal derfor ikke give en tast, _
ellers ville den taste 2 gange.
If .Flags <> 128 Then
Call objForm.HookKeyDown(CInt(.vkCode), mShift)
End If
End Select
End With
End If
KeyboardProc = CallNextHookEx(ByVal 0, _
ByVal nCode, _
ByVal wParam, _
ByVal lParam)
End Function
Public Sub HookKeyboard(frm As Form)
Set objForm = frm
Call UnHookKeyboard
hkKeyboard = SetWindowsHookEx(WH_KEYBOARD_LL, _
AddressOf KeyboardProc, _
App.hInstance, 0)
End Sub
Public Sub UnHookKeyboard()
If hkKeyboard <> 0 Then
Call UnhookWindowsHookEx(hkKeyboard)
hkKeyboard = 0
End If
End Sub
**** ModKeyboard.Bas code end ****
**** ModMouseHook.Bas code ****
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
MouseData As Long
Flags As Long
Time As Long
dwExtraInfo As Long
End Type
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal cbLength As Long)
' Left mouse button
Private Const WM_LBUTTONDBLCLK As Long = &H203
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_LBUTTONDOWN As Long = &H201
' Midt mouse button
Private Const WM_MBUTTONDBLCLK As Long = &H209
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
' Right mouse button
Private Const WM_RBUTTONDBLCLK As Long = &H206
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WH_MOUSE_LL As Long = 14&
Private Const HC_ACTION As Long = 0&
Private m_objForm As Object
Private m_hLLMouseHook As Long
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode = HC_ACTION Then
Select Case wParam
Case WM_MOUSEMOVE
Dim MHook As MSLLHOOKSTRUCT
Call CopyMemory(MHook, ByVal lParam, Len(MHook))
Call m_objForm.API_MouseMove(MHook.pt.X, MHook.pt.Y)
Case WM_LBUTTONUP
Call m_objForm.API_MouseEvent("left")
Case WM_MBUTTONUP
Call m_objForm.API_MouseEvent("middle")
Case WM_RBUTTONUP
Call m_objForm.API_MouseEvent("right")
Case Else
'** Call m_objForm.API_MouseEvent("???" & wParam) to look-up new mouse events (ie. 4th button etc. ?? )
End Select
End If
LowLevelMouseProc = CallNextHookEx(m_hLLMouseHook, nCode, wParam, lParam)
End Function
Public Sub SetMouseHook(objForm As Object)
If m_hLLMouseHook = 0 Then
m_hLLMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, App.hInstance, 0&)
Set m_objForm = objForm
End If
End Sub
Public Sub UnMouseHook()
If m_hLLMouseHook <> 0 Then
Call UnhookWindowsHookEx(m_hLLMouseHook)
m_hLLMouseHook = 0
End If
End Sub
**** ModMouseHook.bas code end ****
Jeg vil ikke have point for noget en anden har lavet, jeg har blot redigeret en lille smule, og det jeg har lavet, er kun af dårlig kvalitet.
Ny bruger
Nybegynder
Opret
Preview
