控制3D游戏中的鼠标

时间：2018-04-16 23:52:22

标签： vba excel-vba excel

我有以下代码控制鼠标（从this source修改）：

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
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Control()
  Wait 3000
  Pos 6, 145
  Down
  Pos 6, 149
  Up
  Pos 7, 147
  Down
  Up
  Pos 8, 145
  Down
  Pos 8, 149
  Up
  Pos 10, 145
  Down
  Pos 10, 149
  Up
  Pos 11, 145
  Down
  Pos 12, 145
  Up
  Pos 11, 147
  Down
  Up
  Pos 11, 149
  Down
  Pos 12, 149
  Up
  Pos 14, 145
  Down
  Pos 14, 149
  Up
  Pos 15, 149
  Down
  Pos 16, 149
  Up
  Pos 18, 145
  Down
  Pos 18, 149
  Up
  Pos 19, 145
  Down
  Pos 20, 145
  Up
  Pos 20, 146
  Down
  Pos 20, 146
  Up
  Pos 19, 147
  Down
  Pos 20, 147
  Up
End Sub
Private Function Wait(Optional ByVal milliseconds As Long = 50)
  Sleep milliseconds
End Function
Private Function Pos(ByVal x As Long, ByVal y As Long)
  SetCursorPos x, y
End Function
Private Function Down()
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
End Function
Private Function Up()
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Function

按预期工作，可以画画。

现在我想要完成的是在游戏VRChat中绘制3D，它将鼠标置于屏幕中间。

在游戏中，鼠标的向下和向上事件有效，但试图改变它的位置根本不会移动它。

该代码在游戏外部工作但在游戏中不起作用以移动由鼠标控制的相机。我正在寻找的是能够使用代码自动移动游戏中的鼠标/相机。

VRChat 3D Drawing

3 个答案:

答案 0 :(得分：0)

下面是代码，您可以使用它来循环移动光标

'Declare mouse events
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
'Declare sleep
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub CityscapeSkyline()
'Open MS Paint and select Natural pencil Brush with 6px width
For k = 1 To 3
  SetCursorPos 16, 500
  Sleep 50
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  For i = 16 To 600 Step 5
    For j = 500 To 300 Step -Int((180 - 10 + 1) * Rnd + 10)
      SetCursorPos i, j
      Sleep 10
    Next j
  Next i
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
Next k
End Sub

如果您还需要使用当前光标位置，那么您也可以集成GetCursorPos 

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type

Sub GetCursorPosDemo()
Dim llCoord As POINTAPI
' Get the cursor positions
GetCursorPos llCoord
' Display the cursor position coordinates
MsgBox "X Position: " & llCoord.Xcoord & vbNewLine & "Y Position: " & llCoord.Ycoord
End Sub

PS：致https://wellsr.com/vba/2015/excel/vba-mouse-move-and-mouse-click-macro/

的积分

答案 1 :(得分：0)

使用GetCursorPos API获取当前光标位置，然后进行相对偏移。 PosRel(xOffSet As Long, yOffSet As Long)＆lt; - 这个子就是这样做的。

在您的代码下面现在修改为包含支持声明，PosRel子和用于测试光标的子进行相对移动

Option Explicit
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
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

''ADDED
    Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

    ' GetCursorPos requires a variable declared as a custom data type
    ' that will hold two integers, one for x value and one for y value
    Type POINTAPI
       X_Pos As Long
       Y_Pos As Long
    End Type


    Public Sub Test()
        Dim beforePOS As POINTAPI, afterPOS As POINTAPI

        GetCursorPos beforePOS
        PosRel 500, -500
        GetCursorPos afterPOS

        MsgBox "Before (" & beforePOS.X_Pos & "," & beforePOS.Y_Pos & ") " & vbNewLine & "After (" & afterPOS.X_Pos & "," & afterPOS.Y_Pos & ") "
    End Sub
    Public Sub PosRel(xOffSet As Long, yOffSet As Long)
        Dim currentPOs As POINTAPI
        GetCursorPos currentPOs
        SetCursorPos currentPOs.X_Pos + xOffSet, currentPOs.Y_Pos + yOffSet

    End Sub
''END ADDED

Sub Control()
  Wait 3000
  Pos 6, 145
  Down
  Pos 6, 149
  Up
  Pos 7, 147
  Down
  Up
  Pos 8, 145
  Down
  Pos 8, 149
  Up
  Pos 10, 145
  Down
  Pos 10, 149
  Up
  Pos 11, 145
  Down
  Pos 12, 145
  Up
  Pos 11, 147
  Down
  Up
  Pos 11, 149
  Down
  Pos 12, 149
  Up
  Pos 14, 145
  Down
  Pos 14, 149
  Up
  Pos 15, 149
  Down
  Pos 16, 149
  Up
  Pos 18, 145
  Down
  Pos 18, 149
  Up
  Pos 19, 145
  Down
  Pos 20, 145
  Up
  Pos 20, 146
  Down
  Pos 20, 146
  Up
  Pos 19, 147
  Down
  Pos 20, 147
  Up
End Sub
Private Function Wait(Optional ByVal milliseconds As Long = 50)
  Sleep milliseconds
End Function
Private Function Pos(ByVal x As Long, ByVal y As Long)
  SetCursorPos x, y
  DoEvents
End Function
Private Function Down()
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
End Function
Private Function Up()
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Function

答案 2 :(得分：0)

我不确定这是不是你使用的，只是一种不同的风格，但我能够将鼠标准确地放在屏幕上我想要的位置。我正在使用双显示器，因此可能会有一点不同。

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_MOVE = &H1          ' mouse move
Private Const MOUSEEVENTF_LEFTDOWN = &H2      ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4        ' left button up
Private Const MOUSEEVENTF_RIGHTDOWN = &H8     ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10      ' right button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20   ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40     ' middle button up
Private Const MOUSEEVENTF_WHEEL = &H800       ' wheel button rolled
Private Const MOUSEEVENTF_ABSOLUTE = &H8000   ' absolute move

Private Type POINTAPI
    x As Long
    y As Long
End Type


Sub myClick()
    Dim pt As POINTAPI
    Dim x As Long
    Dim y As Long

    '(0,0) = top left
    '(65535,65535) = bottom right
    x = 18800
    y = 11600

    LeftClick x, y
End Sub

Sub LeftClick(x As Long, y As Long)
'Move mouse
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, x, y, 0, 0

'Press left click
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0

'Release left click
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

'Trying a wait here..
Application.Wait (Now + TimeValue("0:00:03"))

'Move to bottom of the screen
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, 40000, 47000, 0, 0

'Trying a wait here..
Application.Wait (Now + TimeValue("0:00:02"))

'Try to scroll the page down
mouse_event MOUSEEVENTF_WHEEL, 0, 0, -490, 0

'Trying a wait here..
'Application.Wait (Now + TimeValue("0:00:00"))

'Press left click
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0

'Release left click
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

End Sub
相关问题
最新问题