运行时错误1004：屏幕截图后工作表类的粘贴方法失败

Question

我尝试使用 AppActivate 和 Sendkeys 1068 截取某些应用程序的屏幕截图并粘贴到 Excel 工作表，但是有时，我会在 Activesheet.Paste,

上收到 1004 错误

“Worksheet 类的粘贴方法失败”。

有时宏会起作用。我无法确定为什么会发生这种情况。

任何人都可以识别代码的问题吗？使用 Application.CutCopyMode = False 清除剪贴板有时有效，但并非总是有效。

Sub testscreenshotplusemail()

Dim r As Range
Dim outMail As Outlook.MailItem
Dim wordDoc As Word.Document
Dim count As Integer

AppActivate ("TESTING")

Application.CutCopyMode = False

Application.SendKeys "(%{1068})"

DoEvents

Application.Wait (Now + TimeValue("00:00:02"))

Range("A5").Select

ActiveSheet.Paste

For Each pic In ActiveSheet.Pictures
count = count + 1
Next pic

If count = 0 Then
Exit Sub
End If

Set r = Range("A12:F37")
r.Copy

Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Set outMail = outlookApp.CreateItem(olMailItem)

SelectionBehalf = Worksheets("Sheet1").Range("F3").Value
SelectionTO = Worksheets("Sheet1").Range("G3").Value
SelectionCC = Worksheets("Sheet1").Range("H3").Value
SelectionSubj = Worksheets("Sheet1").Range("I3").Value
SelectionBody = Worksheets("Sheet2").Range("F2").Value

With outMail
.SentOnBehalfOfName = SelectionBehalf
.Display
.To = SelectionTO
.CC = SelectionCC
.Subject = SelectionSubj
.Body = SelectionBody

Set wordDoc = outMail.GetInspector.WordEditor

wordDoc.Range(Start:=wordDoc.Range.End - 1).PasteAndFormat wdChartPicture


End With

For Each pic In ActiveSheet.Pictures
pic.Delete
Next pic
Application.SendKeys "{NUMLOCK}"
Application.CutCopyMode = False

End Sub

Answer 1

使用

SendKeys

是一种可靠的编程方式。使用 Windows API 函数，而不是依赖键盘命令，因为其他软件或应用程序可能会阻止成功运行代码。有关更多信息，请参阅如何使用 VBA 进行屏幕捕获。

Answer 2

我也有同样的问题。就我而言，这是因为用户启用了 Windows 辅助功能设置“使用打印屏幕键打开截图工具”。因此，在用户可以进行任何剪切之前，在代码中尝试了粘贴命令，因此它试图粘贴空白。

希望这有帮助。

我今天早上发布了一个关于如何绕过/禁用此截图工具设置的单独问题，但还没有答案。