苦苦追索多日无果 恳请高手指点迷津 请求高手修改下VBA能实现的全局钩子！！
我好想知道答案啊！！现在心情特别焦急，偏执型精神病又犯了.....
找了好多代码，无奈本人水平有限未能看的个明了，贴出三段代码，恳求高手帮忙修改下代码，小生不胜感谢！！
以下三段是某些好心人的代码，我稍稍修改了，但是无法实现键盘钩子：
代码1：
'用VB实现的全局键盘钩子
'2010-04-06 13:30
'代码功能：实时监测Caps Lock、NumLock、Scroll Lock三个按件的状态，
'并显示在Label1 Label2 Label3三个标签中
'.bas模块中
Public m_hDllKbdHook As Long 'public variable holding
'the handle to the hook procedure
Public Const WH_KEYBOARD_LL As Long = 13 'enables monitoring of keyboard
'input events about to be posted
'in a thread input queue
Private Const HC_ACTION As Long = 0 'wParam and lParam parameters
'contain information about a
'keyboard message
Public Const VK_CAPITAL As Long = &H14
Public Const VK_NUMLOCK As Long = &H90
Public Const VK_SCROLL As Long = &H91
Private Const LLKHF_UP As Long = &H80& 'test the transition-state flag
Public Type KeyboardBytes
kbByte(0 To 255) As Byte
End Type
Private Type KBDLLHOOKSTRUCT
vkCode As Long 'a virtual-key code in the range 1 to 254
scanCode As Long 'hardware scan code for the key
flags As Long 'specifies the extended-key flag,
'event-injected flag, context code,
'and transition-state flag
time As Long 'time stamp for this message
dwExtraInfo As Long 'extra info associated with the message
End Type
Public 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
Public Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal cb As Long)
Public Declare Function GetKeyboardState Lib "user32" _
(kbArray As KeyboardBytes) As Long
Public Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Public Function LowLevelKeyboardProc(ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim kbdllhs As KBDLLHOOKSTRUCT
If nCode = HC_ACTION Then
Call CopyMemory(kbdllhs, ByVal lParam, Len(kbdllhs))
If (kbdllhs.flags And LLKHF_UP) Then
Select Case kbdllhs.vkCode
Case VK_NUMLOCK
Range("A1") = (GetKeyState(VK_NUMLOCK) = &HFF81)
Case VK_CAPITAL
Range("A1") = (GetKeyState(VK_CAPITAL) = &HFF81)
Case VK_SCROLL
Range("A1") = (GetKeyState(VK_SCROLL) = &HFF81)
Case Else
End Select
End If
End If 'nCode = HC_ACTION
LowLevelKeyboardProc = CallNextHookEx(m_hDllKbdHook, _
nCode, _
wParam, _
lParam)
End Function
Sub Form_Load()
Dim kbdState As KeyboardBytes
Call GetKeyboardState(kbdState)
' With Label1
' .Caption = "Numlock is ON"
' .Alignment = vbRightJustify
' End With
' With Label2
' .Caption = "Caps lock is ON"
' .Alignment = vbRightJustify
' End With
' With Label3
' .Caption = "Scroll lock is ON"
' .Alignment = vbRightJustify
' End With
' Label1.Visible = kbdState.kbByte(VK_NUMLOCK) = 1
' Label2.Visible = kbdState.kbByte(VK_CAPITAL) = 1
' Label3.Visible = kbdState.kbByte(VK_SCROLL) = 1
Range("B1") = kbdState.kbByte(VK_NUMLOCK) = 1
Range("B2") = kbdState.kbByte(VK_CAPITAL) = 1
Range("B3") = kbdState.kbByte(VK_SCROLL) = 1
'set and obtain the handle to the keyboard hook
m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, _
AddressOf LowLevelKeyboardProc, _
0&, _
0&)
If m_hDllKbdHook = 0 Then 'App.Hinstance
MsgBox "Failed to install low-level keyboard hook."
End If
End Sub
Sub Unload() 'Cancel As Integer, UnloadMode As Integer
If m_hDllKbdHook <> 0 Then
Call UnhookWindowsHookEx(m_hDllKbdHook)
End If
End Sub
[最优解释]
不可能运行不了，你注意到说明没有？除两个按钮外，其余属性都是默认的
1、先在form上添加两个按钮，一个叫“安装钩子”，一个叫“卸载钩子”，指的是Caption,不是name
2、表单代码部份必须复制到窗体代码块
3、模块代码部份必须复制到模块中，不能复制到窗体中
4、代表Excel的不是App,而是Application,所以
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf MyKBHook, App.hInstance, 0)
应改为
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf MyKBHook, Application.Hinstance, 0)
5、运行不了你应写出错误提示，否则谁也帮不了你
[其他解释]
全局键盘鼠标的HOOK在WIN2000以上就有专门的HOOK类型了,你们上面也用到了的.
我这里有个类,别人在EXCEL里也实际用过的,拿去用不是了,弄得太麻烦了.
http://www.m5home.com/bak_blog/article/245.html
这是封装好的键盘鼠标全局HOOK类.
[其他解释]
代码2：
'VB: 全局键盘鼠标钩子
'---------------------------------
'---------------------------------
'模块
Public 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
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function CallNextHookEx Lib "user32" _
(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" _
(lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Public Type KEYMSGS
vKey As Long '虚拟码 (and &HFF)
sKey As Long '扫描码
flag As Long '键按下：128 抬起：0
time As Long 'Window运行时间
End Type
Public Type MOUSEMSGS
X As Long 'x座标
Y As Long 'y座标
a As Long
b As Long
time As Long 'Window运行时间
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Const WH_KEYBOARD_LL = 13
Public Const WH_MOUSE_LL = 14
Public Const Alt_Down = &H20
'-----------------------------------------
'消息
Public Const HC_ACTION = 0
Public Const HC_SYSMODALOFF = 5
Public Const HC_SYSMODALON = 4
'键盘消息
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_SYSKEYDOWN = &H104
Public Const WM_SYSKEYUP = &H105
'鼠标消息
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_MOUSEACTIVATE = &H21
Public Const WM_MOUSEFIRST = &H200
Public Const WM_MOUSELAST = &H209
Public Const WM_MOUSEWHEEL = &H20A
Public Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public strKeyName As String * 255
Public Declare Function GetActiveWindow Lib "user32" () As Long
Public keyMsg As KEYMSGS
Public MouseMsg As MOUSEMSGS
Public lHook(1) As Long
'----------------------------------------
'模拟鼠标
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
'--------------------------------------
'模拟按键
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'鼠标钩子
Public Function CallMouseHookProc _
(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim pt As POINTAPI
If code = HC_ACTION Then
CopyMemory MouseMsg, lParam, LenB(MouseMsg)
Range("A1") = "X=" + Str(MouseMsg.X) + " Y=" + Str(MouseMsg.Y)
Range("A2") = Format(wParam, "0")
If wParam = WM_MBUTTONDOWN Then '把中键改为左键
MsgBox "M L D"
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
CallMouseHookProc = 1
End If
If wParam = WM_MBUTTONUP Then
MsgBox "M L UP"
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
CallMouseHookProc = 1
End If
End If
If code <> 0 Then
CallMouseHookProc = CallNextHookEx(0, code, wParam, lParam)
End If
End Function
'键盘钩子
Public Function CallKeyHookProc _
(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lKey As Long, strKeyName As String * 255, strLen As Long
If code = HC_ACTION Then
CopyMemory keyMsg, lParam, LenB(keyMsg)
Select Case wParam
Case WM_SYSKEYDOWN, WM_KEYDOWN, WM_SYSKEYUP, WM_KEYUP:
lKey = keyMsg.sKey And &HFF '扫描码
lKey = lKey * 65536
strLen = GetKeyNameText(lKey, strKeyName, 250)
Form1.txtMsg(0).Text = "键名:" + Left(strKeyName, strLen) + " 虚拟码:" + Format(keyMsg.vKey And &HFF, "0") + " 扫描码:" + Format(lKey / 65536, "0")
Form1.txtHwnd(0) = ""
If (GetKeyState(vbKeyControl) And &H8000) Then
Form1.txtHwnd(0) = Form1.txtHwnd(0) + "Ctrl "
End If
If (keyMsg.flag And Alt_Down) <> 0 Then
Form1.txtHwnd(0) = Form1.txtHwnd(0) + "Alt "
End If
If (GetKeyState(vbKeyShift) And &H8000) Then
Form1.txtHwnd(0) = Form1.txtHwnd(0) + "Shift"
End If
'keyMsg.vKey And &HFF 虚拟码
'lKey / 65536 扫描码
If (keyMsg.vKey And &HFF) = vbKeyY Then '把Y键替换为N
If wParam = WM_SYSKEYDOWN Or wParam = WM_KEYDOWN Then
keybd_event vbKeyN, 0, 0, 0
End If
CallKeyHookProc = 1 '屏蔽按键
End If
End Select
End If
If code <> 0 Then
CallKeyHookProc = CallNextHookEx(0, code, wParam, lParam)
End If
End Function
'===================================================================
'Form
'安装钩子
Sub AddHook()
'键盘钩子
MsgBox HC_ACTION
lHook(0) = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CallKeyHookProc, 0, 0)
'鼠标钩子
lHook(1) = SetWindowsHookEx(WH_MOUSE_LL, AddressOf CallMouseHookProc, 0, 0)
End Sub
'卸钩子
Sub DelHook()
UnhookWindowsHookEx lHook(0)
UnhookWindowsHookEx lHook(1)
End Sub
代码3：
'VB全局钩子
'WH_KEYBOARD_LL这个常数表示键盘全局钩子 AddressOf MyKBHook求出钩子函数MyKBHook的内存地址
'App.hInstance是本程序的模块句柄，也就是钩子函数所在的模块，最后一个参数0表示全局钩子
Public hHook As Long '用来存放钩子的句柄
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
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
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public a As Long
Public Type EVENTMSG
vKey As Long
sKey As Long
flag As Long
time As Long
End Type
Public mymsg As EVENTMSG
Public Const WH_KEYBOARD_LL = 13
Public Const WM_KEYDOWN = &H100
Public Function MyKBHook(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'这些参数在不同钩子中具有不同含义，在这里ncode 是类型代码
If ncode = 0 Then
If wParam = WM_KEYDOWN Then
'在这里wParam 表示键盘事件，具体的按键信息保存在lParam 指针所指向的内存区域中
'把内存中lParam 指针所指向的数据复制到mymsg这个自定义类型
CopyMemory mymsg, ByVal lParam, Len(mymsg)
'你要做的事情
Range("A1") = mymsg.sKey
End If
End If
'将消息传给下一个钩子，如果你想锁定键盘，只需要把这句改成MyKBHook =-1，表示吃掉这个消息，这样键盘就输入不了了:-)
MyKBHook = CallNextHookEx(hHook, ncode, wParam, lParam)
End Function
Sub ADDHOOK1111()
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf MyKBHook, 0, 0)
'If hHook = 0 Then End '如果钩子注册失败会返回0，否则返回注册的钩子句柄
Application.Wait (Now + TimeValue("0:00:30"))
UnhookWindowsHookEx hHook
End Sub
Sub ADDHOOK()
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf MyKBHook, App.Hinstance, 0)
If hHook = 0 Then End '如果钩子注册失败会返回0，否则返回注册的钩子句柄
End Sub
Sub DELHOOK(Cancel As Integer)
UnhookWindowsHookEx hHook
End Sub
[其他解释]
或许答案就在眼前 近在迟尺 希望能有高手伸出援手救我啊！
我希望能
1：实现autohotkey的键盘按键对调的功能，
2：实现按键精灵的键盘鼠标记录功能（这个应该有另外的方法实现，有一对记录鼠标键盘的API函数）
为什么按键精灵一句话就能实现的东西 我要花大力气去学习呢?
因为智慧的高尚的，求知是快乐的！：）
[其他解释]
有点遗憾地告诉你，VB很难实现全局钩子，原因在于真正的全局钩子必须用DLL注入（windows不允许一个进程直接调用另一进程的代码），糟糕地是VB6的DLL又不能直接导出函数（国外有人做了个插件，可导出函数，但实际并不好用），所以，好点的解决方案是C做DLL，VB来调用（还不如直接用C做）
[其他解释]
cyd您好，请问VB调用API写的程序不是和C写的的功能差不多的吗？
另外调用API肯定可以实现全局钩子的，问题是我还没能找到代码，非常希望您能出手相助啊！
[其他解释]
是因为我把 App.hInstance 改为 0 出错了吗？
好像说0就是全局钩子？
[其他解释]
问题不在VB能不能调用API，而在于hook Api需要一个回调函数作参数，但由于VB6的设计原因，VB的函数不能被其它进程直接调用（注意，你写的钩子事实是由系统调用，而不是你的程序调用），这个问题好比是你的朋友（系统）声称只要告诉他方法，他什么都能做(他给了你API)。但你被关在屋子里，没有电话，没有网络（VB的DLL只导出对象，不直接导出函数,函数被封在了对象中），因此你无法告诉你朋友方法(钩子函数)，你朋友当然也就什么都做不了
[其他解释]
0就是全局钩子的前提是你的钩子函数也是全局的，但VB6无法做全局的钩子函数，因此也就做不了全局的钩子
[其他解释]
非常感谢您精妙的比喻和热心的回复！！
请问单单做个键盘的全局HOOK应该没问题吧。另外请教您全局需要调用DLL，不过做线程钩子VB是可以的，不好意思再请教下您请问线程钩子大概需要如何修改下代码呢？
[其他解释]
3段代码大同小异，以下是第三段改的，可直接运行看看：
先在form上添加两个按钮，一个叫“安装钩子”，一个叫“卸载钩子”
表单代码：
Option Explicit
Private Sub Command1_Click()
ADDHOOK '安装钩子
End Sub
Private Sub Command2_Click()
UNHOOK '卸载钩子
End Sub
模块代码：
以下代码必须在模块中
'VB全局钩子
'WH_KEYBOARD_LL这个常数表示键盘全局钩子 AddressOf MyKBHook求出钩子函数MyKBHook的内存地址
'App.hInstance是本程序的模块句柄，也就是钩子函数所在的模块，最后一个参数0表示全局钩子
Public hHook As Long '用来存放钩子的句柄
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
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
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public a As Long
Public Type EVENTMSG
vKey As Long
sKey As Long
flag As Long
time As Long
End Type
Public mymsg As EVENTMSG
Public Const WH_KEYBOARD_LL = 13
Public Const WM_KEYDOWN = &H100
Public Function MyKBHook(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'这些参数在不同钩子中具有不同含义，在这里ncode 是类型代码
If ncode = 0 Then
If wParam = WM_KEYDOWN Then
'在这里wParam 表示键盘事件，具体的按键信息保存在lParam 指针所指向的内存区域中
'把内存中lParam 指针所指向的数据复制到mymsg这个自定义类型
CopyMemory mymsg, ByVal lParam, Len(mymsg)
'你要做的事情
'显示按下的键
MsgBox "你按了" & Chr(mymsg.vKey)
End If
End If
'将消息传给下一个钩子，如果你想锁定键盘，只需要把这句改成MyKBHook =-1，表示吃掉这个消息，这样键盘就输入不了了:-)
MyKBHook = CallNextHookEx(hHook, ncode, wParam, lParam)
End Function
Sub ADDHOOK()
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf MyKBHook, App.hInstance, 0)
If hHook = 0 Then
'如果钩子注册失败会返回0，否则返回注册的钩子句柄
MsgBox "钩子注册失败"
End If
End Sub
'卸钩子
Sub UNHOOK()
UnhookWindowsHookEx hHook
End Sub
[其他解释]
是不是因为我太菜了 为什么我的VB运行不了呢？放进EXCEL VBA也无法运行 5555555555
[其他解释]
非常抱歉！！昨天代码不能运行，我都生自己的气了！！
非常非常感谢您不厌其烦的教导啊！！终于成功了！！
就是代码有些问题，无法识别右边的数字键和组合键等，总之非常感谢您啊！！
请教您能用EXCEL VBA写一个hook记事本的代码给我吗？
[其他解释]
非常抱歉！！昨天代码不能运行，我都生自己的气了！！
非常非常感谢您不厌其烦的教导啊！！终于成功了！！
就是代码有些问题，无法识别右边的数字键和组合键等，总之非常感谢您啊！！
请教您能用EXCEL VBA写一个hook记事本的代码给我吗？
[其他解释]
老马您好，这名字让我想起了马克思啊 哈哈哈哈^^
请教您这个是如何使用的呢？另外类我还没有用过哦~~非常抱歉!
请问您能再出和简易点的教程给我这种很希望能入门又有点撞了墙进不去的人吗？
anyway Thankyou verymuch! :)
[其他解释]
1、mymsg.vKey是windows转换后的虚拟码，只能识别字母数字等Ascii字符键，识别所有键应使用mymsg.sKey,即扫描码，至于什么码代表什么键，你自己试试或查查资料就行了。
2、上面的主要代码完全可在Excel中运行,只需把App.hInstance改为Application.Hinstance就行，前面己有说明。至于什么时候，什么地方挂钩子就取决于你了，ADDHOOK，挂，UNHOOK，卸；只需注意模块代码也应写在VBA的模块中。
3、hook记事本，前面己经说过，VB（包括VBA)是很难实现的，因为记事本和EXcel是两个进程；如果只是想拦截记事本的键盘消息，你就把MyKBHook改一下
Public Function MyKBHook(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'这些参数在不同钩子中具有不同含义，在这里ncode 是类型代码
If ncode = 0 Then
CopyMemory mymsg, ByVal lParam, Len(mymsg)
'你要做的事情
Dim hw As Long
hw = FindWindow("Notepad", vbNullString) '查找记事本窗口
If GetForegroundWindow() = hw Then '判断当前窗口是不是记事本窗口
'显示按下的键
MsgBox "记事本" & Chr(mymsg.vKey)
End If
End If
'将消息传给下一个钩子，如果你想锁定键盘，只需要把这句改成MyKBHook =-1，表示吃掉这个消息，这样键盘就输入不了了:-)
MyKBHook = CallNextHookEx(hHook, ncode, wParam, lParam)
End Function
声明
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
加在模块前面
[其他解释]
奇怪了 一运行ECEL就崩溃了 应该是指针导致的吧
[其他解释]
真的非常非常感谢c_cyd2008您的不厌其烦的细致的教学！！
KISS!! ^^
非常感谢！！
[其他解释]
要正确运行得确保很多，要崩溃只是一小点，耐心点吧；
贴给你的代码已在Excel中实测过，是可行的，但仅限于所贴部份，你有加减就不好说了；