Excelマクロを実行している間にスナップツールがスナップを開始しませんか？

Question

画面の一部を自動的に切り取りたいと思っています。私は、その後にこれを持って

'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 

（参照用の画像を参照してください）私は最初のマウスが開始すべき場所を設定するためのキャリブレーションマクロを持って

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

：私はこれらのライブラリや定義を使用していますサブ（私はこの問題は非常に最後に発生したと考えている）：

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 

Snipping Toolをオーバーレイが現れたことがないとマウスだけで座標間のすべてのものを選択します。オーバーレイは、マウスイベントがない場合に表示されますが、マウスイベントが必要です。

編集：私はいくつかヘッドウェイを作った。私はスナップにそれを得ることができました、しかし、それは非常に信頼性がありません。 SetCursorPosを使用してSnipping Toolの新機能を手動でクリックして動作させます。たぶん、誰かがもっと信頼できる方法を見つけ出すことができますか？以下の変更されたコード：

'--------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コードです。スナッパーを実行するコードではない場合、走っている。

決定的な回答は次のとおりです。他のツールでこれを行います。上のリンクのMicrosoftからの提案は、Visual Studio Tools for Officeです。これが始める場所です。さらに、スレッドの問題と別のプロセスの必要性だけではなく、イベントドリブンコードを実行するVBAの能力は、移動するマウスカーソルから来るウィンドウメッセージトラフィックの消防隊員を処理するのに十分速いわけではありません。

VBAで行う必要がある場合は、コードを「スリープ」状態またはロック状態にして受信トラフィックをブロックするすべてのものを取り除くことで、問題を緩和することができます。おそらくApplication.Waitで置き換えることができます）、WMIスクリプト（プロセスの列挙のためのAPI呼び出しで置き換えることができます）、MsgBox呼び出し（シェルのPopup関数で置き換えることができます。 -ブロッキング）。

しかし、一番下の行は同じです：これは彼の後ろ足で歩くために犬を教え似ている「作業」の特定の値のために、VBAに働くかもしれない：

「「TISよくやっていません。しかし、あなたはそれがすべて "で行われているのを見て驚いています。