在运行Excelmacros时，剪切工具不启动剪贴板？
我想自动剪切屏幕的一个区域。 我正在使用这些库和定义：
'------ 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 我首先有一个校准macros来设置鼠标开始的位置（参考图片） 
'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
剪切工具覆盖从不出现，鼠标只是select坐标之间的一切。 如果鼠标事件不存在，则会显示叠加层，但是我需要鼠标事件才能使其工作！
编辑：我已经取得了一些进展。 我能够得到它， 但它是非常不可靠的。 我使用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
简短版本是： Excel中的VBA是单线程的 。
如果您的Excel.exe会话中运行了VBAmacros，那么它将是主机应用程序会话中唯一运行的VBA代码：如果它不是运行您的snipper的代码，则snipper不会运行。
确切的答案是： 在其他工具中做这个 。 微软在上面的链接中提出的build议是Visual Studio Tools for Office，这是开始的地方。 此外，您的问题不仅仅是线程问题，而且需要一个单独的过程：VBA运行事件驱动代码的能力不足以处理来自移动的鼠标光标的窗口消息stream量的消防。
如果您必须在VBA中执行此操作，则可以通过删除将代码置于“睡眠”或locking状态以阻止传入stream量的所有内容，而不是“睡眠”（可能会被replace通过Application.Wait），WMI脚本（可以用API调用进程枚举来取代）和MsgBox调用（可以用shell的“popup”function取代，这是非模态的和非阻塞的）。
但底线仍然是一样的：这可能在VBA中起作用，因为“工作”的某些值类似于教狗后腿走路：
“做得不好，但你惊讶地发现它完成了” 。