VBS使用excel模拟鼠标移动点击问题

系统：win10 64位
excel : 2019

问题：使用oExcel.Run "SetCursorPos", 30, 30 方法设置鼠标位置不生效（鼠标要么跑到左上角，要么跑到左下角）。

想要达到的结果：设置鼠标到制定位置，进行鼠标左右键点击。（求能完成操作的全部源码）

目前出错的代码如下：
Option Explicit

Dim WshShell
Dim oExcel, oBook, oModule
Dim strRegKey, strCode, x, y
Set oExcel = CreateObject("Excel.Application") '创建 Excel 对象

set WshShell = CreateObject("wscript.Shell")

strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office$\Excel\Security\AccessVBOM"
strRegKey = Replace(strRegKey, "$", oExcel.Version)

WshShell.RegWrite strRegKey, 1, "REG_DWORD"

Set oBook = oExcel.Workbooks.Add '添加工作簿
Set oModule = obook.VBProject.VBComponents.Add(1) '添加模块
strCode = _
"Private Type POINTAPI : X As Long : Y As Long : End Type" & vbCrLf & _
"Private Declare PtrSafe Function SetCursorPos Lib ""user32"" (ByVal x As Integer, ByVal y As Integer) As Integer" & vbCrLf & _
"Private Declare PtrSafe Function GetCursorPos Lib ""user32"" (lpPoint As POINTAPI) As Long" & vbCrLf & _
"Private Declare PtrSafe Sub mouse_event Lib ""user32"" Alias ""mouse_event"" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)" & vbCrLf & _
"Public Function GetXCursorPos() As Long" & vbCrLf & _
"Dim pt As POINTAPI : GetCursorPos pt : GetXCursorPos = pt.X" & vbCrLf & _
"End Function" & vbCrLf & _
"Public Function GetYCursorPos() As Long" & vbCrLf & _
"Dim pt As POINTAPI: GetCursorPos pt : GetYCursorPos = pt.Y" & vbCrLf & _
"End Function" & vbCrLf & _
"Private Sub SetCursor(x,y)" & vbCrLf & _
"SetCursorPos x, y" & vbCrLf & _
"End Sub"

oModule.CodeModule.AddFromString strCode '在模块中添加 VBA 代码

x = oExcel.Run("GetXCursorPos") '获取鼠标 X 坐标
y = oExcel.Run("GetYCursorPos") '获取鼠标 Y 坐标

WScript.Echo x, y
oExcel.Run "SetCursorPos", 30, 30 '设置鼠标 X Y 坐标
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_LEFTDOWN = &H2

Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40

Const MOUSEEVENTF_ABSOLUTE = &H8000
'模拟鼠标左键单击
oExcel.Run "mouse_event", MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

'模拟鼠标左键双击（即快速的两次单击）
oExcel.Run "mouse_event", MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
oExcel.Run "mouse_event", MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

'模拟鼠标右键单击
oExcel.Run "mouse_event", MOUSEEVENTF_RIGHTDOWN + MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
'模拟鼠标中键单击
oExcel.Run "mouse_event", MOUSEEVENTF_MIDDLEDOWN + MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0

'关闭 Excel
oExcel.DisplayAlerts = False
oBook.Close
oExcel.Quit

关键问题没有使用绝对坐标系：1、增加了绝对坐标系定位，这样就可以用绝对坐标来确定点击位置；2、简化了代码，将api声明和过程语句全部写入excel模块，调用vba运行，VBS中的调用语句为 oExcel.Run "moveClick(x,y)" ，x,y为点击位置。
在windows10 64位上 excel2019版试过，可以用，实现鼠标移动至指定位置，并且右键点击。

将以下代码复制黏贴至文本文档→另存为名称.vbs 文件，编码选ANSI，双击即可运行，如有疑问请留言。

，vbs代码：


Option Explicit
'定义变量
Dim WshShell
Dim oExcel, oBook, oModule
Dim strRegKey, strCode, x, y
Dim path,fileName,fileFullName,currentpath

'表格操作
Set oExcel = CreateObject("Excel.Application")         '创建 Excel 对象
set WshShell = CreateObject("wscript.Shell")    
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office$\Excel\Security\AccessVBOM"
strRegKey = Replace(strRegKey, "$", oExcel.Version)
WshShell.RegWrite strRegKey, 1, "REG_DWORD"
Set oBook = oExcel.Workbooks.Add             '添加工作簿
Set oModule = obook.VBProject.VBComponents.Add(1)     '添加模块

'模块代码
strCode = _
"Private Declare Sub mouse_event Lib ""user32"" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)" & vbCrLf & _
"Private Declare Function SetCursorPos Lib ""user32""  (ByVal x As Long, ByVal y As Long) As Long" & vbCrLf & _
"Private Const MOUSEEVENTF_ABSOLUTE = &H8000 '指定鼠标使用绝对坐标系，此时，屏幕在水平和垂直方向上均匀分割成65535×65535个单元" & vbCrLf & _
"Private Const MOUSEEVENTF_MOVE = &H1        '移动鼠标" & vbCrLf & _
"Private Const MOUSEEVENTF_RIGHTDOWN = &H8   '模拟鼠标右键按下" & vbCrLf & _
"Private Const MOUSEEVENTF_RIGHTUP = &H10    '模拟鼠标右键抬起" & vbCrLf & _
"Declare Function GetSystemMetrics32 Lib ""user32"" Alias ""GetSystemMetrics"" (ByVal nIndex As Long) As Long '获取分辨率" & vbCrLf & _
"Sub moveClick(x,y)'移动并点击" & vbCrLf & _
"SetCursorPos x,y '移动鼠标" & vbCrLf & _
"mouse_event MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0    '点击鼠标" & vbCrLf & _
"End Sub"

oModule.CodeModule.AddFromString strCode        '在模块中添加 VBA 代码

oExcel.Run "moveClick(100,100)"              '设置鼠标 X Y 坐标

'关闭 Excel
oExcel.DisplayAlerts = False
oBook.Close
oExcel.Quit

只需复制代码并将其粘贴到Excel中的宏窗口中即可，望采纳。


Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10

Private Sub SingleClick()
  SetCursorPos 100, 100 'x ，y 坐标
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Private Sub DoubleClick()
  '两次快速单击视为双击
  SetCursorPos 100, 100 'x ，y 坐标
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Private Sub RightClick()
  '右击
  SetCursorPos 200, 200 'x ，y 坐标
  mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub

Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 '指定鼠标使用绝对坐标系，此时，屏幕在水平和垂直方向上均匀分割成65535×65535个单元
Private Const MOUSEEVENTF_MOVE = &H1 '移动鼠标
Private Const MOUSEEVENTF_LEFTDOWN = &H2 '模拟鼠标左键按下
Private Const MOUSEEVENTF_LEFTUP = &H4 '模拟鼠标左键抬起
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long '获取分辨率
Type POINTAPI
X As Long
Y As Long
End Type

Private Sub Screen_Click(ByVal X As Long, ByVal Y As Long) '移动并点击
mw = X / GetSystemMetrics32(0) * 65535
mh = Y / GetSystemMetrics32(1) * 65535
mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, mw, mh, 0, 0
mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Public Function getmouse_x_y() As POINTAPI '坐标
GetCursorPos getmouse_x_y

End Function
Sub DisplayMonitorInfo()
Dim X As Long, Y As Long
X = GetSystemMetrics32(0) ' 宽度（像素）
Y = GetSystemMetrics32(1) ' 高度（像素）
MsgBox "屏幕分辨率为：" & X & " × " & Y & " 像素"
End Sub
Sub GetPosition() '获得坐标
Debug.Print getmouse_x_y.X, getmouse_x_y.Y
[D2] = getmouse_x_y.X
[D3] = getmouse_x_y.Y
End Sub
Sub test()
Screen_Click [D2], [D3]
End Sub
试试这个代码

https://blog.csdn.net/weixin_39892309/article/details/109975438?spm=1005.2026.3001.5635&utm_medium=distribute.pc_relevant_ask_down.none-task-blog-2~default~OPENSEARCH~Rate-4.pc_feed_download_top3ask&depth_1-utm_source=distribute.pc_relevant_ask_down.none-task-blog-2~default~OPENSEARCH~Rate-4.pc_feed_download_top3ask

用按键精灵

Public Function getmouse_x_y() As POINTAPI '坐标
GetCursorPos getmouse_x_y

参考下这个吧，不一定满足你的要求，嘿嘿

你是想实现什么吗