VB键盘模拟的小程序代码2

1.

'模块

'API声明

Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal

wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long,

ByVal wMapType As Long) As Long

Declare Function FindWindow Lib "" Alias "FindWindowA" (ByVal lpClassName As

String, ByVal lpWindowName As String) As Long

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 Const WM_KEYDOWN = &H100

Public Const WM_KEYUP = &H101

Public Const WM_CHAR = &H102

Public Const VK_A = &H41

'这个函数来构造postmessage的lparam参数。

Function MakeKeyLparam(ByVal VirtualKey As Long, ByVal flag As Long) As Long

Dim s As String

Dim Firstbyte As String 'lparam参数的24-31位

If flag = WM_KEYDOWN Then '如果是按下键

Firstbyte = "00"

Else

Firstbyte = "C0" '如果是释放键

End If

Dim Scancode As Long

'获得键的扫描码

Scancode = MapVirtualKey(VirtualKey, 0) '可查MSDN，或者中文API手册

Dim Secondbyte As String 'lparam参数的16-23位，即虚拟键扫描码

Secondbyte = Right("00" & Hex(Scancode), 2)

s = Firstbyte & Secondbyte & "0001" '0001为lparam参数的0-15位，即发送次数和其它扩展信息

MakeKeyLparam = Val("&H" & s)

End Function

'在窗体里编写下面代码 , 通过打印的值我们就可以知道一些我们需要的值

Private Sub Command1_Click()

1

Dim tWnd As Long

tWnd = FindWindow(vbNullString, " - 记事本")

Print Hex(tWnd)

tWnd = FindWindowEx(tWnd, 0, "Edit", vbNullString)

Print Hex(tWnd)

Dim ret As Long

ret = MakeKeyLparam(VK_A, WM_KEYDOWN)

Print Hex(ret)

PostMessage tWnd, WM_KEYDOWN, VK_A, ret

'PostMessage tWnd, WM_CHAR, Asc("A"), MakeKeyLparam(VK_A, WM_KEYDOWN)

'PostMessage tWnd, WM_KEYDOWN, VK_A, MakeKeyLparam(VK_A, WM_UP)

End Sub

'这个可以实现后台的模拟键盘输入。可惜现在很多游戏用不了了，毕竟我们都知道了，游戏制作者也知道了，我们就要做点他们不知道的咯。

--------------------------------------------------------------------------------------------------

Option Explicit

Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode

As Long, ByVal wMapType As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As

Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName

As String, ByVal lpWindowName As String) As Long

Private 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

Private Const WM_KEYDOWN = &H100

Private Const WM_KEYUP = &H101

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long,

ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Sub Command1_Click()

Dim jsb As Long

jsb = FindWindow("notepad", vbNullString)

Dim mhwnd As Long

mhwnd = FindWindowEx(jsb, 0, "edit", vbNullString)

Dim lParam As Long

lParam = makelparam(vbKey5, False)

PostMessage mhwnd, WM_KEYDOWN, vbKey5, lParam

lParam = makelparam(vbKey5, True)

PostMessage mhwnd, WM_KEYUP, vbKey5, lParam

2

End Sub

Private Function makelparam(ByVal VirtualKey As Long, ByVal flag As Boolean) As Long

Dim s As String

Dim Firstbyte As String 'lparam参数的24-31位

If flag = False Then 'keydown

Firstbyte = "00"

Else

Firstbyte = "C0" 'keyup

End If

Dim Scancode As Long

'获得虚拟键扫描码

Scancode = MapVirtualKey(VirtualKey, 0)

Dim Secondbyte As String 'lparam参数的16-23位，即虚拟键扫描码

Secondbyte = Right("00" & Hex(Scancode), 2)

s = Firstbyte & Secondbyte & "0001" '0001为lparam参数的0-15位，即发送次数

makelparam = Val("&H" & s)

End Function

===================================================================================================

2.

'模块

Declare Function SendInput Lib "" (ByVal nInputs As Long, pInputs As

GENERALINPUT, ByVal cbSize As Long) As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any,

ByVal ByteLen As Long)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Type GENERALINPUT

dwType As Long

xi(0 To 23) As Byte

End Type

Type KEYBDINPUT

wVk As Integer

wScan As Integer

dwFlags As Long

time As Long

dwExtraInfo As Long

End Type

3

Const INPUT_KEYBOARD = 1

Public Const VK_A = &H41

Sub MySendKey(bkey As Long)

'参数bkey传入要模拟按键的虚拟码即可模拟按下指定键

Dim GInput(0 To 1) As GENERALINPUT

Dim KInput As KEYBDINPUT

= bkey '你要模拟的按键

s = 0 '按下键标志

GInput(0).dwType = INPUT_KEYBOARD

CopyMemory GInput(0).xi(0), KInput, Len(KInput) '这个函数用来把内存中KInput的数据复制到GInput

= bkey

s = KEYEVENTF_KEYUP ' 释放按键

GInput(1).dwType = INPUT_KEYBOARD ' 表示该消息为键盘消息

CopyMemory GInput(1).xi(0), KInput, Len(KInput)

'以上工作把按下键和释放键共2条键盘消息加入到GInput数据结构中

SendInput 2, GInput(0), Len(GInput(0)) '把GInput中存放的消息插入到消息列队

End Sub

'窗体

Private Sub Command1_Click()

'Dim i As Integer

'For i = 0 To 30

MySendKey VK_A '按下A键

'Sleep 500 '延时500毫秒

'Next i

End Sub

=============================================================================================

3.

'模块

Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long,

ByVal wMapType As Long) As Long

Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal

dwFlags As Long, ByVal dwExtraInfo As Long)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const VK_A = &H41

'窗体

4

Private Sub Command1_Click()

'Dim i As Integer

'For i = 0 To 30

keybd_event VK_A, 0, 0, 0 '按下A键

'Sleep 500 '延时500毫秒

'Next i

End Sub

'对一些DIRECTX游戏，最好还是用

'先获得按键的扫描码

'keybd_event VK_A, MapVirtualKey(VK_A, 0), 0, 0 '按下A键

'OK,执行就可以体验了，选中一个可以输入的地方。

Private Sub Command2_Click()

'Dim i As Integer

'For i = 0 To 30

keybd_event VK_A, MapVirtualKey(VK_A, 0), 0, 0 '按下A键

'Sleep 500 '延时500毫秒

'Next i

End Sub

---------------------------------------------------------------------------------------------------------

'在窗口内加入控件command1，text1，其中：text1用于输入电话号码用，command1用于自动拨号。然后在代码区复制下面代码，运行，即可看到效果。

'====窗体代码====

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName

As String, ByVal lpWindowName As String) As Long

Private 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

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As

Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As

Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long,

ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hwnd

As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal

hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As

Long

Private Const EM_LINELENGTH = &HC1

Private Const EM_SETSEL = &HB1

5

Private Const EM_REPLACESEL = &HC2

Private Const WM_SETFOCUS = &H7

Private Const WM_KEYDOWN = &H100

Private Const WM_KEYUP = &H101

Function GetWinClass(hwd As Long) As String

Dim retvalue As Long, TempStr As String * 254

retvalue = GetClassName(hwd, TempStr, 254)

GetWin vbFromUnicode), retvalue), vbUnicode)

End Function

Public Sub SendWinText(hwd As Long, SendString As String)

Dim k As Long, aClass As String

If hwd = 0 Then Exit Sub

'Edit控件时

a

If InStr(1, aClass, "Edit", vbTextCompare) <> 0 Or InStr(1, aClass, "TextBox", vbTextCompare)

<> 0 Then

k = SendMessage(hwd, EM_LINELENGTH, 1, 0) '取得文本宽度

SendMessageByNum hwd, EM_SETSEL, 0, k '选中文本

SendMessageByString hwd, EM_REPLACESEL, 1, SendString '传递文本

End If

End Sub

Public Sub SendWinKey(hwd As Long, vbkey, Wait As Boolean)

Dim i As Integer, J As Integer, s As String, Tmp As String

If hwd = 0 Then Exit Sub

SendMessage hwd, WM_SETFOCUS, 0&, 0& '选中按钮

If Wait = True Then

Sleep 100

SendMessage hwd, WM_KEYDOWN, vbkey, 0& '模拟按下指定键

Sleep 100

SendMessage hwd, WM_KEYUP, vbkey, 0&

Else

Dim lParam As Long

'lParam = makelparam(vbkey, False)

PostMessage hwd, WM_KEYDOWN, vbkey, 0 '模拟按下指定键

'lParam = makelparam(vbkey, True)

PostMessage hwd, WM_KEYUP, vbkey, 0

End If

End Sub

Private Sub Command1_Click()

Dim mWnd As Long, mSubWnd As Long

6

mWnd = FindWindow(vbNullString, "帮拨猫")

If mWnd = 0 Then

MsgBox "帮拨猫没有启动，无法完成拨号功能！", vbInformation, "提示"

Exit Sub

End If

mSubWnd = FindWindowEx(mWnd, 0&, "Edit", vbNullString)'查找控件

SendWinText mSubWnd, trim() '输入电话号码

mSubWnd = FindWindowEx(mWnd, 0&, "Button", vbNullString)'查找控件

SendWinKey mSubWnd, vbKeyReturn, False '自动拨号

End Sub

-----------------------------------------------------------------------------

'看了你的问题补充才知道：顺序把Text1与text2的内容依次传递到游戏里的某个窗口，然后按回车键，从而达到自动发送信息的目的。

'下面分两步实现上述目的

'第一步，请先建立一个模块，并输入复制以下内容：

'-----------bas-----------

Option Explicit

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long,

ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const EM_LINELENGTH = &HC1

Public Const EM_REPLACESEL = &HC2

Public Const EM_SETSEL = &HB1

Public Const WM_KEYDOWN = &H100

Public Const WM_KEYUP = &H101

Public Sub SendWinText(hwd As Long, SendString As String)

Dim k As Long, aClass As String

If hwd = 0 Then Exit Sub

k = SendMessage(hwd, EM_LINELENGTH, 1, 0) '取得文本宽度

SendMessageByNum hwd, EM_SETSEL, 0, k '选中文本

SendMessageByString hwd, EM_REPLACESEL, 1, SendString '传递文本

End Sub

Public Sub SendWinKey(hwd As Long, vbkey)

Dim i As Integer, J As Integer, s As String, tmp As String

If hwd = 0 Then Exit Sub

SendMessage hwd, WM_KEYDOWN, vbkey, 0& '模拟按下指定键

SendMessage hwd, WM_KEYUP, vbkey, 0&

End Sub

'--------------end-------------

7

'第2步：

'假设游戏发送信息的文本框的hwnd已知(设为hwd)，则游戏自动发送信息的关键代码如下：

SendWinText hwd, '向游戏文本框发送text1文本

SendWinKey hwd,13 '回车按键

SendWinText hwd, '向游戏文本框发送text2文本

SendWinKey hwd,13 '回车按键

'OK，祝你好运！

-------------------------------------------------------------------------------------------------------------

VB后台发送ALT组合键的源代码

'首先，你必须获取到目标窗口的Hwnd，然后分二步:

'第一步，建立一个模块,复制下面代码到模块中，并保存

'===代码====

Option Explicit

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As

Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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)

Private Const WM_SETFOCUS = &H7

Private Const KEYEVENTF_EXTENDEDKEY = &H1

Private Const KEYEVENTF_KEYUP = &H2

Public Sub KeyDown(ByVal vKey As Long) '用keybd_event模拟按下键盘

keybd_event vKey, 0, KEYEVENTF_EXTENDEDKEY, 0

End Sub

Public Sub KeyUp(ByVal vKey As KeyCodeConstants) '用keybd_event模拟松开键盘

keybd_event vKey, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0

End Sub

Public Function SendKeyToWnd(MainWnd As Long, vbkey, Shift) As Boolean

SetForegroundWindow MainWnd'把目标窗口置前

SendMessage MainWnd, WM_SETFOCUS, 0&, 0& '选中按钮

If Shift Then KeyDown Shift '复合键

KeyDown vbkey '普通键

Sleep 100

KeyUp vbkey

If Shift Then KeyUp Shift

End Function

8

'第二步，函数调用：在你的工程内添加文件，选择刚才保存的文件，然后在调用处输入以下代码即可。

SendKeyToWnd hwnd, vbKeyZ, vbKeyMenu ‘向hwnd对应的窗口发送ALT+Z命令

9