运行Excel宏时，Snipping Tool不会启动剪辑？

Question

我想自动剪切屏幕区域。我使用这些库和定义：

'------ I don't own these functions. Copied them from the Internet. ------
Public Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
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
'The following two functions are for retrieving the color under mouse pointer
Public Declare Function GetWindowDC Lib "User32" (ByVal hwnd As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Public Function IsExeRunning(sExeName As String, Optional sComputer As String = ".") As Boolean
On Error GoTo Error_Handler
Dim objProcesses    As Object

Set objProcesses = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2").ExecQuery("SELECT * FROM Win32_Process WHERE Name = '" & sExeName & "'")
If objProcesses.Count <> 0 Then IsExeRunning = True

Error_Handler_Exit:
On Error Resume Next
Set objProcesses = Nothing
Exit Function

Error_Handler:
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
        "Error Number: IsExeRunning" & vbCrLf & _
        "Error Description: " & Err.Description, _
        vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function

我首先有一个校准宏来设置鼠标应该从哪里开始（参见图片以供参考）

'Calibrate mouse positions for GetColor sub below
'I realize I could just use two corner points, but I didn't think of that until after this was used.
Sub CalibrateColorPositions()

MsgBox "Please hover over the top center of the ArtCam work area (just under the top ruler) and press Enter.", vbOKOnly
GetCursorPos pos
SaveSetting "Will's Program Sheet", "CP Calibration", "Top Y", pos.y
SaveSetting "Will's Program Sheet", "CP Calibration", "Top X", pos.x

MsgBox "Please hover over the right center of the ArtCam work area (just left of the scrollbar) and press Enter.", vbOKOnly
GetCursorPos pos
SaveSetting "Will's Program Sheet", "CP Calibration", "Right Y", pos.y
SaveSetting "Will's Program Sheet", "CP Calibration", "Right X", pos.x

MsgBox "Please hover over the bottom center of the ArtCam work area (just above the scrollbar) and press Enter.", vbOKOnly
GetCursorPos pos
SaveSetting "Will's Program Sheet", "CP Calibration", "Bottom Y", pos.y
SaveSetting "Will's Program Sheet", "CP Calibration", "Bottom X", pos.x

MsgBox "Please hover over the left center of the ArtCam work area (just right of the ruler) and press Enter.", vbOKOnly
GetCursorPos pos
SaveSetting "Will's Program Sheet", "CP Calibration", "Left Y", pos.y
SaveSetting "Will's Program Sheet", "CP Calibration", "Left X", pos.x

MsgBox "Thanks! Calibration finished!", vbOKOnly
End Sub

然后我在Sub中有这个（我相信问题发生在最后）：

Sub GetColor()
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
Dim vSide As Integer
Dim TranslateX As Double, TranslateY As Double
Dim CurrentPosX As Long, CurrentPosY As Long
Dim TopX As Long, TopY As Long, RightX As Long, RightY As Long, BottomX As Long, BottomY As Long, LeftX As Long, LeftY As Long
Dim FinalTop As Long, FinalRight As Long, FinalBottom As Long, FinalLeft As Long

Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = False
Dim windowStyle As Integer: windowStyle = 1

TopX = GetSetting("Will's Program Sheet", "CP Calibration", "Top X", 0)
If TopX = 0 Then
CalibrateColorPositions 'Set calibration coordinates and exit sub
Exit Sub
End If

'Retrieve calibrated coordinates and set them to variables
TopY = GetSetting("Will's Program Sheet", "CP Calibration", "Top Y", 0)
RightX = GetSetting("Will's Program Sheet", "CP Calibration", "Right X", 0)
RightY = GetSetting("Will's Program Sheet", "CP Calibration", "Right Y", 0)
BottomX = GetSetting("Will's Program Sheet", "CP Calibration", "Bottom X", 0)
BottomY = GetSetting("Will's Program Sheet", "CP Calibration", "Bottom Y", 0)
LeftX = GetSetting("Will's Program Sheet", "CP Calibration", "Left X", 0)
LeftY = GetSetting("Will's Program Sheet", "CP Calibration", "Left Y", 0)

sTmp = "535353" 'Our ArtCam programs have a gray background

'Run four times (Top, Right, Bottom, and Left)
For vSide = 1 To 4
Select Case vSide
Case 1
'Move mouse to position
CurrentPosX = TopX
CurrentPosY = TopY
'Which direction should the mouse move?
TranslateX = 0
TranslateY = 10
Case 2
CurrentPosX = RightX
CurrentPosY = RightY
TranslateX = -10
TranslateY = 0
sTmp = "535353"
Case 3
CurrentPosX = BottomX
CurrentPosY = BottomY
TranslateX = 0
TranslateY = -10
sTmp = "535353"
Case 4
CurrentPosX = LeftX
CurrentPosY = LeftY
TranslateX = 10
TranslateY = 0
sTmp = "535353"
End Select

While sTmp = "535353" 'If color under mouse is still gray, translate mouse.

CurrentPosX = CurrentPosX + TranslateX
CurrentPosY = CurrentPosY + TranslateY
SetCursorPos CurrentPosX, CurrentPosY

lDC = GetWindowDC(0)
GetCursorPos pos
lColor = GetPixel(lDC, pos.x, pos.y)

sTmp = Right$("000000" & Hex(lColor), 6)
Debug.Print ("R:" & Right$(sTmp, 2) & " G:" & _
     Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2))
Wend
'Once it has detected a different color, save that position for later.
Select Case vSide
Case 1
FinalTop = CurrentPosY
Case 2
FinalRight = CurrentPosX
Case 3
FinalBottom = CurrentPosY
Case 4
FinalLeft = CurrentPosX
End Select
Next
'Start Snipping Tool (and automatically start snip if necessary)
Application.CutCopyMode = False
wsh.Run "C:\Windows\sysnative\SnippingTool.exe"
x = 0
Select Case Mid(Application.OperatingSystem, 21)
Case 6.02
Do Until IsExeRunning("SnippingTool.exe") = True Or x = 500
x = x + 1
Loop
Sleep (350)
'--------PROBLEM IS ASSUMED HERE-------
AppActivate "Snipping Tool", True
Application.SendKeys "^N", True
End Select

SetCursorPos FinalLeft - 10, FinalTop - 10
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
SetCursorPos FinalRight + 10, FinalBottom + 10
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

剪切工具叠加层从不显示，鼠标只选择坐标之间的所有内容。如果鼠标事件不存在，则会出现叠加层，但我需要鼠标事件才能使其正常工作！

编辑：我已经取得了一些的进展。我能够让它剪断，但它非常不可靠。我使用SetCursorPos手动单击“剪切工具上的新建”并运行。也许有人可以找出更可靠的方法或提供一些提示？更改了以下代码：

'--------PROBLEM IS ASSUMED HERE-------
'AppActivate "Snipping Tool", True
'testageNew
End Select

snipposition 'Manually click New (Sub below)

Sleep (500) 'Add some delay for it to start.

'Click and hold the top left to the bottom right position (AKA, take snip)
SetCursorPos FinalLeft - 10, FinalTop - 10
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
SetCursorPos FinalRight + 10, FinalBottom + 10
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Sub snipposition()
'Made separate Sub for user to test coordinates without running whole Sub.
SetCursorPos 850, 250 'Coordinates of Snipping Tool New button.
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 'Click it.
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Answer 1

简短版本为：VBA in Excel is single-threaded。

如果您在Excel.exe会话中运行了VBA宏，它是在您的主机应用程序会话中运行的唯一VBA代码：如果它不是运行您的snipper的代码，你的片段没有运行。

明确的答案是：在其他工具中执行此操作。 Microsoft在上面的链接中提出的建议是Visual Studio Tools for Office，这是一个值得一去的地方。此外，您的问题不仅仅是线程问题和对单独流程的需求：VBA运行事件驱动代码的能力还不够快，无法处理窗口消息的消防站来自移动鼠标光标的流量。

如果您必须在VBA中执行此操作，则可以通过删除将代码置于“睡眠”状态的所有内容来缓解您所看到的问题。阻止传入流量的锁定状态：不仅仅是“睡眠”状态。 （可能由Application.Wait替换），WMI脚本（可以用进程枚举的API调用替换）和MsgBox调用（可以用shell＆＃39; Popup＆＃39;函数替换） ，非模态和非阻塞）。

但是底线仍然是相同的：这可能适用于VBA，因为某些“工作”的价值观。这就像教狗狗用后腿走路一样：

＆＃34;做得不好;但你很惊讶地发现它已经完成了＃34; 。