|
- Option Explicit
- '*************************************************************************
- '**模 块 名:ModSSendKeys
- '**说 明:模拟按键(直接发按键消息到输入队列,多数情况下与直接按键盘效果相等)
- '**创 建 人:嗷嗷叫的老马
- '**日 期:2006年5月10日
- '**描 述:网上收集,更改了部分代码.
- '**备 注: 紫水晶工作室 版权所有
- '** 更多模块/类模块请访问我站: http://www.m5home.com
- '**版 本:V2.0
- '**日 期:2011年7月16日
- '**描 述:更新了ASCII到虚拟键码的转换.
- '*************************************************************************
- '*************************************************************************
- '**模 块 名:ModSSendKeys
- '**说 明:模拟键鼠(直接发按键消息到输入队列,多数情况下与直接按键盘效果相等)
- '**创 建 人:小卢
- '**描 述:收集自http://www.m5home.com
- '**日 期:20012年10月15日
- '**描 述:更新增加鼠标事件
- '*************************************************************************
- Private Const KEYEVENTF_KEYUP = &H2
- Private Const INPUT_MOUSE = 0
- Private Const INPUT_KEYBOARD = 1
- Private Const INPUT_HARDWARE = 2
- Private Const MOUSEEVENTF_LEFTDOWN = &H2
- Private Const MOUSEEVENTF_LEFTUP = &H4
- Private Const MOUSEEVENTF_MOVE = &H1
- Private Const MOUSEEVENTF_RIGHTDOWN = &H8
- Private Const MOUSEEVENTF_RIGHTUP = &H10
- Private Const SM_CXSCREEN = 0
- Private Const SM_CYSCREEN = 1
- Private Const MOUSEEVENTF_ABSOLUTE = &H8000
- Private Type MOUSEINPUT
- dx As Long
- dy As Long
- mouseData As Long '鼠标滚轮
- dwFlags As Long '事件
- time As Long '时间戳
- dwExtraInfo As Long '扩展信息
- End Type
- Private Type KEYBDINPUT
- wVk As Integer '键码
- wScan As Integer '安全码
- dwFlags As Long '事件
- time As Long
- dwExtraInfo As Long
- End Type
- Private Type HARDWAREINPUT
- uMsg As Long
- wParamL As Integer
- wParamH As Integer
- End Type
- Private Type GENERALINPUT
- dwType As Long
- xi(0 To 23) As Byte
- End Type
- Private Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As GENERALINPUT, ByVal cbSize As Long) As Long
- Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
- Public Declare Sub Sleep Lib "kernel32.dll" ( _
- ByVal dwMilliseconds As Long)
- Private Declare Function VkKeyScan Lib "user32.dll" Alias "VkKeyScanA" ( _
- ByVal cChar As Byte) As Integer
- Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
- Public Declare Function GetTickCount Lib "kernel32" () As Long
- Public Declare Function GetMessageExtraInfo Lib "user32" () As Long
- Public Sub SendKey(ByVal bKey As KeyCodeConstants)
- Dim GInput(0 To 1) As GENERALINPUT
- Dim KInput As KEYBDINPUT
- Dim I As Long, iH As Integer, iL As Integer
-
- I = VkKeyScan(bKey)
- Call CopyMemory(iL, I, 2)
- Call CopyMemory(iH, I + 2, 2)
-
- Debug.Print Hex(iL), Hex(iH)
-
-
- KInput.wVk = iL '我们要按的关键
- KInput.dwFlags = 0 '按下
- '结构复制到输入数组的缓冲区。
- GInput(0).dwType = INPUT_KEYBOARD ' 键盘输入
- CopyMemory GInput(0).xi(0), KInput, Len(KInput)
- '执行与上述相同,但用于释放键
- KInput.wVk = bKey '
- KInput.dwFlags = KEYEVENTF_KEYUP ' 释放
- GInput(1).dwType = INPUT_KEYBOARD ' 键盘输入
- CopyMemory GInput(1).xi(0), KInput, Len(KInput)
- '发送按键
- Call SendInput(1, GInput(0), Len(GInput(0)))
- DoEvents
- End Sub
- Public Sub MoveTo(ByVal dx As Long, ByVal dy As Long)
- Dim GInput As GENERALINPUT
- Dim KInput As MOUSEINPUT
- Debug.Print GetSystemMetrics(SM_CXSCREEN)
- Debug.Print GetSystemMetrics(SM_CYSCREEN)
- KInput.dx = (65535 \ (GetSystemMetrics(SM_CXSCREEN) - 1)) * dx
- KInput.dy = (65535 \ (GetSystemMetrics(SM_CYSCREEN) - 1)) * dy
- KInput.dwFlags = MOUSEEVENTF_MOVE Or MOUSEEVENTF_ABSOLUTE '鼠标移动
- KInput.mouseData = 0
- KInput.time = GetTickCount
- KInput.dwExtraInfo = GetMessageExtraInfo
- '结构复制到输入数组的缓冲区。
- GInput.dwType = INPUT_MOUSE ' 鼠标输入
- CopyMemory GInput.xi(0), KInput, Len(KInput)
- Call SendInput(1, GInput, Len(GInput))
- End Sub
- Public Sub LeftClick()
- Dim GInput(0 To 1) As GENERALINPUT
- Dim KInput As MOUSEINPUT
- KInput.dwFlags = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_ABSOLUTE '鼠标按下左键
- KInput.mouseData = 0
- KInput.time = GetTickCount
- KInput.dwExtraInfo = GetMessageExtraInfo
- '结构复制到输入数组的缓冲区。
- GInput(0).dwType = INPUT_MOUSE ' 鼠标输入
- CopyMemory GInput(0).xi(0), KInput, Len(KInput)
-
- '执行与上述相同,但用于释放键
- KInput.dwFlags = MOUSEEVENTF_LEFTUP Or MOUSEEVENTF_ABSOLUTE '鼠标按下左键
- KInput.mouseData = 0
- KInput.time = GetTickCount
- KInput.dwExtraInfo = GetMessageExtraInfo
- '结构复制到输入数组的缓冲区。
- GInput(1).dwType = INPUT_MOUSE ' 鼠标输入
- CopyMemory GInput(1).xi(0), KInput, Len(KInput)
- Call SendInput(1, GInput(0), Len(GInput(0)))
- Sleep 10
- Call SendInput(1, GInput(1), Len(GInput(1)))
- End Sub
- Public Function RightClick()
- Dim GInput(0 To 1) As GENERALINPUT
- Dim KInput As MOUSEINPUT
- KInput.dwFlags = MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_ABSOLUTE '鼠标按下右键
- KInput.mouseData = 0
- KInput.time = GetTickCount
- KInput.dwExtraInfo = GetMessageExtraInfo
- '结构复制到输入数组的缓冲区。
- GInput(0).dwType = INPUT_MOUSE ' 鼠标输入
- CopyMemory GInput(0).xi(0), KInput, Len(KInput)
-
- '执行与上述相同,但用于释放键
- KInput.dwFlags = MOUSEEVENTF_RIGHTUP '鼠标按下右键
- KInput.mouseData = 0
- KInput.time = GetTickCount
- KInput.dwExtraInfo = GetMessageExtraInfo
- '结构复制到输入数组的缓冲区。
- GInput(1).dwType = INPUT_MOUSE Or MOUSEEVENTF_ABSOLUTE ' 鼠标输入
- CopyMemory GInput(1).xi(0), KInput, Len(KInput)
- Call SendInput(2, GInput(0), Len(GInput(0)))
- Sleep 10
- Call SendInput(1, GInput(1), Len(GInput(1)))
- End Function
- Public Function DbLeftClick()
- Call LeftClick
- Call LeftClick
- End Function
- Public Function DbRingtClick()
- Call RightClick
- Call RightClick
- End Function
- Public Sub SendStr(ByVal theStr As String)
- '发送字符串
- Dim I As Long
-
- For I = 1 To Len(theStr)
- Call SendKey(Asc(Mid(theStr, I, 1)), 0)
- Sleep 100
- Call SendKey(Asc(Mid(theStr, I, 1)), 1)
- Next
- End Sub
复制代码 |
|