運行Excel宏時，截取工具不啓動剪貼板？

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 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的代碼，那麼您的snipper isn'運行。

確定的答案是：在一些其他工具中執行此操作。微軟在上面的鏈接中提出的建議是Visual Studio Tools for Office，這就是開始的地方。此外，您的問題不僅僅是線程問題，而且需要一個單獨的過程：VBA運行事件驅動代碼的能力不足以處理來自移動鼠標光標的窗口消息流量的消防站。

如果您必須在VBA中執行此操作，您可以通過剝離將您的代碼置於「睡眠」或鎖定狀態來阻止傳入流量的所有事情來緩解您遇到的問題：不僅僅是「睡眠」（其中可能會被Application.Wait替換），WMI腳本（可以用API調用進程枚舉來替代），以及MsgBox調用（可以用shell的'Popup'函數替換，這些函數是非模態的和非模態的-blocking）。

但底線仍然是相同的：這可能在VBA工作，爲「工作」，類似於教狗走在他的後腿的某些值：

叨唸「這是不是做得很好;但你很驚訝地發現它完成了「。