Narzędzie do wycinania nie uruchamia wycinków podczas uruchamiania programu Excel Macro?

Question

Chcę automatycznie wyciąć obszar ekranu. Używam tych bibliotek i definicje:

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

ja najpierw makro kalibracji utworzenia gdzie mysz powinny zacząć (patrz zdjęcie dla odniesienia)

'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 wtedy to w sub (wierzę, że problem występuje na samym końcu):

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 

nakładka Narzędzie Wycinanie nigdy nie pokazuje się i mysz po prostu wybiera wszystko między współrzędnymi. Nakładka pojawia się, jeśli nie ma zdarzeń myszy, ale POTRZEBUJĘ zdarzeń myszy, aby to zadziałało!

EDYCJA: Zrobiłem niektórych zjechania. Udało mi się go wyciąć, , ale jest bardzo niewiarygodne. Używam SetCursorPos do ręcznego klikania New na Snipping Tool i działa. Być może ktoś może wymyślić bardziej niezawodną metodę lub podać kilka wskazówek? Zmieniono poniższy kod:

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

Skrócona wersja to: VBA in Excel is single-threaded.

Jeśli masz makro VBA uruchomione w sesji Excel.exe, jest to jedyny kod VBA uruchomiony w twojej sesji aplikacji hosta: a jeśli to nie jest kod, który uruchamia twój snipper, twój snipper isn ' t uruchomiony.

Ostateczna odpowiedź brzmi: zrobić to w innym narzędziu. Sugestia firmy Microsoft w powyższym linku to Visual Studio Tools for Office, i to jest miejsce, od którego należy zacząć. Ponadto twój problem to nie tylko kwestia wątków i potrzeba oddzielnego procesu: zdolność VBA do uruchamiania kodu sterowanego zdarzeniami nie jest wystarczająco szybka, aby poradzić sobie z firewallem ruchu wiadomości w oknie, który pochodzi od ruchomego kursora myszy. .

Jeśli musisz to zrobić w VBA, możesz złagodzić problemy, które widzisz, usuwając wszystko, co umieszcza twój kod w "uśpieniu" lub stanie zablokowanym, który blokuje ruch przychodzący: nie tylko "śpij" (co można prawdopodobnie zastąpić aplikacją.Wait), skryptem WMI (który można zastąpić wywołaniami API dla wyliczania procesów) oraz wywołania MsgBox (które można zastąpić funkcją "Popup" powłoki, która to metoda jest niemodalna i nie -bloking).

Ale dolna linia jest wciąż ta sama: to może pracować w VBA dla pewnych wartości „pracy”, które przypominają uczenie psa chodzić na tylnych łapach:

"„Nie Tis zrobić dobrze; ale jesteś zaskoczony, że w ogóle to zrobił ".