运行Excel宏时，剪切工具不会启动剪切？ [英] Snipping Tool does not start a snip while running Excel Macro?

问题描述

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

I want to automatically snip an area of the screen. I'm using these libraries and definitions:

'------ 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

我第一次有一个校准宏来设置鼠标应该开始（请参阅图片供参考）

I first have a calibration macro to set up where the mouse should start (see image for reference)

'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相信问题发生在最后）：

I then have this in a Sub (I believe the problem occurs at the very end):

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

剪贴工具覆盖从不显示，鼠标只是选择坐标之间的所有内容。如果鼠标事件不存在，则重叠出现，但是我需要鼠标事件才能使其发挥作用！

The Snipping Tool overlay never shows up and the mouse just selects everything between the coordinates. The overlay appears if the mouse events aren't there, but I NEED the mouse events to make this work!

编辑：我已经使前进。我得到它来剪辑，但它是非常不可靠的。我使用SetCursorPos手动单击新的剪切工具并且工作。有人可能会想出一个更可靠的方法或提供一些提示？更改以下代码：

I've made some headway. I was able to get it to snip, but it's extremely unreliable. I use SetCursorPos to click the New on Snipping Tool manually and works. Perhaps someone can figure out a more reliable method or provide some tips? Changed code below:

'--------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

推荐答案

简短版本是： Excel中的VBA是单线程的。

如果您的VBA宏正在运行您的Excel.exe会话，它是主持人应用程序会话中运行的唯一VBA代码：如果不是运行您的狙击手的代码，则您的狙击手未运行。

If you have a VBA macro running in your session of Excel.exe, it's the only VBA code running in your session of the host application: and if it isn't the code that runs your snipper, your snipper isn't running.

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

The definitive answer is: do this in some other tool. The suggestion from Microsoft in the link above is Visual Studio Tools for Office, and that's the place to start. Furthermore, your problem isn't just a matter of threading and the need for a separate process: VBA's ability to run event-driven code isn't really fast enough to deal with the firehouse of window message traffic that comes from a moving mouse cursor.

如果您必须在VBA中执行此操作，您可以通过剥离将代码置于睡眠或锁定状态的所有内容来减轻您遇到的问题阻止传入流量：不仅仅是睡眠（可能被Application.Wait替换），WMI脚本（可以用API调用进行过程枚举来代替）和MsgBox调用（可以由shell'Popup'功能，非模态和非阻塞）。

If you have to do it in VBA, you can mitigate the problems you're seeing by stripping out everything which places your code in a 'sleep' or locked state that blocks incoming traffic: not just 'sleep' (which can probably be replaced by an Application.Wait), the WMI script (which can be replaced with API calls for process enumeration), and the MsgBox calls (which can be replaced by the shell 'Popup' function, which non-modal and non-blocking).

但底线仍然是一样的：这可能在VBA中工作，某些值工作类似于教一只狗走在他的后腿：

But the bottom line is still the same: this might work in VBA, for certain values of 'working' that resemble teaching a dog to walk on his hind legs:

做得不好;但是你惊讶地发现它完成了 。

这篇关于运行Excel宏时，剪切工具不会启动剪切？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！