形状复制粘贴计时问题-Excel VBA [英] Shapes Copy Paste Timing Issue - Excel VBA
本文介绍了形状复制粘贴计时问题-Excel VBA的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在使用Windows 10 Enterprise 64位，Office 2016 Pro 64位.我正在尝试将2个形状从一个工作表复制到另一工作表.
以下API代码有时可以工作，但大多数情况下会针对复制或粘贴显示错误1004(剪贴板计时问题).我尝试使用其他解决方案，例如计时器，等待，API等，但在大多数情况下似乎很慢且有故障！ 我也试图将图像粘贴到每个合并的单元格的相对两端.我还附加了示例文件进行检查. >
我不记得了，但是我在某处读到，如果我创建单独的复制和粘贴函数/过程，那么虽然不确定，但可能会解决问题！
Option Explicit
Sub DoIT()
Dim Shp1 As Shape, Shp2 As Shape, Shp3 As Shape, Shp4 As Shape, i&, j&
Dim WK1 As Worksheet, WK2 As Worksheet
With ThisWorkbook
Set WK1 = .Worksheets("test1")
Set WK2 = .Worksheets("test2")
Set Shp1 = WK1.Shapes("Arrow")
Set Shp2 = WK1.Shapes("Consumers")
j = 0
For i = 1 To 20
With WK2.Range(WK2.Cells(i + j, 3), WK2.Cells(i + j, 4))
.Merge 'merge 2 cells
On Error Resume Next
Do
ClearClipboard
Shp1.CopyPicture
WaitOnClipboard
Loop Until Err.Number = 0
On Error GoTo 0
' Pause
'copy paste Arrow shape
On Error Resume Next
Do
Err.Clear
WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
DoEvents
Loop Until Err.Number = 0
On Error GoTo 0
Application.CutCopyMode = False
ClearClipboard
Set Shp3 = WK2.Shapes(WK2.Shapes.Count)
With Shp3
.Top = WK2.Cells(i + j, 3).MergeArea.Top
.Left = WK2.Cells(i + j, 3).MergeArea.Left
End With
' copy paste Consumers shape
On Error Resume Next
Do
ClearClipboard
Shp2.CopyPicture
WaitOnClipboard
Loop Until Err.Number = 0
On Error GoTo 0
' Pause
On Error Resume Next
Do
Err.Clear
WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
DoEvents
Loop Until Err.Number = 0
On Error GoTo 0
Application.CutCopyMode = False
ClearClipboard
Set Shp4 = WK2.Shapes(WK2.Shapes.Count)
With Shp4
.Top = WK2.Cells(i + j, 3).MergeArea.Top
.Left = WK2.Cells(i + j, 3).MergeArea.Left + WK2.Cells(i, 3).MergeArea.Width - Shp2.Width
End With
j = j + 2
End With
Next i
End With
End Sub
API代码:
Option Explicit
' Windows API declarations
#If VBA7 Or Win64 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CountClipboardFormats Lib "user32" () As Long
#End If
Public Sub WaitOnClipboard()
Do
DoEvents
' Loop Until IsPicInClipboard
Loop Until IsPicOnClipboard
End Sub
' Wait until PowerPoint shape object is on the Windows clipboard
Public Sub WaitForClipboard()
Do
DoEvents
' Loop Until IsPicInClipboard
Loop Until IsPicOnClipboard
End Sub
Function IsShapeOnClipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
IsShapeOnClipboard = IsClipboardFormatAvailable(&HC216&)
EmptyClipboard
CloseClipboard
End Function
Function IsPicInClipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
IsPicInClipboard = False
If IsClipboardFormatAvailable(2) <> 0 Or _
IsClipboardFormatAvailable(3) <> 0 Or _
IsClipboardFormatAvailable(9) <> 0 Or _
IsClipboardFormatAvailable(14) <> 0 Or _
IsClipboardFormatAvailable(25) <> 0 Or _
IsClipboardFormatAvailable(29) <> 0 Then IsPicInClipboard = True
End Function
' Check if PowerPoint shape object is on the Windows clipboard
Public Function IsPicOnClipboard() As Boolean
Dim lFormat As Long
Dim sName As String
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
Do
lFormat = EnumClipboardFormats(lFormat)
' sName = String(255, 0)
' sName = Space(255)
' GetClipboardFormatName lFormat, sName, Len(sName)
' Debug.Print lFormat, sName
' If sName Like "*PowerPoint 12.0 Internal Shapes*" Then IsPicOnClipboard = True: Exit Do
' If InStr(1, Trim(lFormat), "14", vbTextCompare) > 0 Then IsPicOnClipboard = True: Exit Do
If (lFormat = 2 Or lFormat = 3 Or lFormat = 9 Or lFormat = 14 Or lFormat = 25 Or lFormat = 29) Then IsPicOnClipboard = True: Exit Do
Loop Until lFormat = 0
CloseClipboard
End Function
Public Sub Pause()
Dim t As Double
t = Timer
Do Until Timer - t > 1
DoEvents
Loop
End Sub
Function IsClipboardEmpty() As Boolean
IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function
Public Function ClearClipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Function
Public Sub CopyShape(ItemName As String, ByRef CopyDestination As Worksheet, ByRef PasteDestination As Worksheet)
Call ClearClipboard
ThisWorkbook.Sheets(CopyDestination).Shapes(ItemName).Copy
ThisWorkbook.Sheets(PasteDestination).Paste
Do Until IsClipboardEmpty = False
DoEvents
Loop
End Sub
Function Is_Pic_in_Clipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Or IsClipboardFormatAvailable(9) <> 0 Then _
Is_Pic_in_Clipboard = True '2=BMP, 14=JPEG, 9=Picture
End Function
Sub ListClipFormats()
Dim Arr, Fmt
Arr = Application.ClipboardFormats
For Each Fmt In Application.ClipboardFormats
Select Case Fmt
Case xlClipboardFormatBIFF Or 8: Debug.Print "Binary Interchange file format for Excel version 2.x"
Case xlClipboardFormatBIFF12 Or 63: Debug.Print "Binary Interchange file format 12"
Case xlClipboardFormatBIFF2 Or 18: Debug.Print "Binary Interchange file format 2"
Case xlClipboardFormatBIFF3 Or 20: Debug.Print "Binary Interchange file format 3"
Case xlClipboardFormatBIFF4 Or 30: Debug.Print "Binary Interchange file format 4"
Case xlClipboardFormatBinary Or 15: Debug.Print "Binary format"
Case xlClipboardFormatBitmap Or 9: Debug.Print "Bitmap format"
Case xlClipboardFormatCGM Or 13: Debug.Print "CGM format"
Case xlClipboardFormatCSV Or 5: Debug.Print "CSV format"
Case xlClipboardFormatDIF Or 4: Debug.Print "DIF format"
Case xlClipboardFormatDspText Or 12: Debug.Print "Dsp Text format"
Case xlClipboardFormatEmbeddedObject Or 21: Debug.Print "Embedded Object"
Case xlClipboardFormatEmbedSource Or 22: Debug.Print "Embedded Source"
Case xlClipboardFormatLink Or 11: Debug.Print "Link"
Case xlClipboardFormatLinkSource Or 23: Debug.Print "Link to the source file"
Case xlClipboardFormatLinkSourceDesc Or 32: Debug.Print "Link to the source description"
Case xlClipboardFormatMovie Or 24: Debug.Print "Movie"
Case xlClipboardFormatNative Or 14: Debug.Print "Native"
Case xlClipboardFormatObjectDesc Or 31: Debug.Print "Object description"
Case xlClipboardFormatObjectLink Or 19: Debug.Print "Object link"
Case xlClipboardFormatOwnerLink Or 17: Debug.Print "Link to the owner"
Case xlClipboardFormatPICT Or 2: Debug.Print "Picture"
Case xlClipboardFormatPrintPICT Or 3: Debug.Print "Print picture"
Case xlClipboardFormatRTF Or 7: Debug.Print "RTF format"
Case xlClipboardFormatScreenPICT Or 29: Debug.Print "Screen Picture"
Case xlClipboardFormatStandardFont Or 28: Debug.Print "Standard Font"
Case xlClipboardFormatStandardScale Or 27: Debug.Print "Standard Scale"
Case xlClipboardFormatSYLK Or 6: Debug.Print "; SYLK"
Case xlClipboardFormatTable Or 16: Debug.Print "; Table"
Case xlClipboardFormatText Or 0: Debug.Print "Text"
Case xlClipboardFormatToolFace Or 25: Debug.Print "Tool Face"
Case xlClipboardFormatToolFacePICT Or 26: Debug.Print "Tool Face Picture"
Case xlClipboardFormatVALU Or 1: Debug.Print "Value"
Case xlClipboardFormatWK1 Or 10: Debug.Print "Workbook"
End Select
Next Fmt
End Sub
Public Sub ListClipboardFormats()
Dim lFormat As Long
Dim sName As String
If OpenClipboard(0&) = 0 Then Exit Sub ' Could not open clipboard
Do
lFormat = EnumClipboardFormats(lFormat)
sName = String(255, 0)
GetClipboardFormatName lFormat, sName, Len(sName)
If Not lFormat = 0 Then Debug.Print lFormat, sName
Loop Until lFormat = 0
EmptyClipboard
CloseClipboard
End Sub
@iinspectable，这不是正常的复制粘贴问题，但是如果循环中涉及复制粘贴，即多次复制粘贴，则不是剪贴板计时问题.这是SingleCopyPaste过程而不是MultipleCopyPaste过程工作的示例.希望你现在明白我的意思.
显式选项
Sub MultipleCopyPaste()
Dim shp As Shape
For Each shp In Sheet1.Shapes
shp.CopyPicture
Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)
Next shp
End Sub
Sub SingleCopyPaste()
Dim shp As Shape
Set shp = Sheet1.Shapes("Arrow")
shp.CopyPicture
Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)
End Sub
解决方案
下面是一个仅在粘贴失败时重试粘贴的示例:
Sub Tester()
Dim pic, i As Long
Set pic = Sheet1.Shapes("testPic")
For i = 1 To 100
pic.Copy
PastePicRetry Sheet2.Cells(i, 2)
Next i
End Sub
'paste problem fix
Sub PastePicRetry(rng As Range)
Dim i As Long
Do While i < 20
On Error Resume Next
rng.PasteSpecial
If Err.Number <> 0 Then
Debug.Print "Paste failed", i
DoEvents
i = i + 1
Else
Exit Do
End If
On Error GoTo 0
i = i + 1
Loop
End Sub
I am using Windows 10 Enterprise 64 bit, Office 2016 Pro 64 bit. I am trying to copy 2 shapes from one worksheet to another worksheet.
The following API code works sometimes, but most times it shoots an Error 1004 for Copy or Paste (Clipboard timing issue). I have tried using different solutions e.g. Timer, Wait, API etc., but seem slow and buggy most of the times! Also i am trying to paste the images on opposite ends of each merged cell. I have also attached a sample file for inspection.
I don't remember but i read somewhere that if i create separate copy and paste functions/procedures, then it might solve the issue, though not sure!
Option Explicit
Sub DoIT()
Dim Shp1 As Shape, Shp2 As Shape, Shp3 As Shape, Shp4 As Shape, i&, j&
Dim WK1 As Worksheet, WK2 As Worksheet
With ThisWorkbook
Set WK1 = .Worksheets("test1")
Set WK2 = .Worksheets("test2")
Set Shp1 = WK1.Shapes("Arrow")
Set Shp2 = WK1.Shapes("Consumers")
j = 0
For i = 1 To 20
With WK2.Range(WK2.Cells(i + j, 3), WK2.Cells(i + j, 4))
.Merge 'merge 2 cells
On Error Resume Next
Do
ClearClipboard
Shp1.CopyPicture
WaitOnClipboard
Loop Until Err.Number = 0
On Error GoTo 0
' Pause
'copy paste Arrow shape
On Error Resume Next
Do
Err.Clear
WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
DoEvents
Loop Until Err.Number = 0
On Error GoTo 0
Application.CutCopyMode = False
ClearClipboard
Set Shp3 = WK2.Shapes(WK2.Shapes.Count)
With Shp3
.Top = WK2.Cells(i + j, 3).MergeArea.Top
.Left = WK2.Cells(i + j, 3).MergeArea.Left
End With
' copy paste Consumers shape
On Error Resume Next
Do
ClearClipboard
Shp2.CopyPicture
WaitOnClipboard
Loop Until Err.Number = 0
On Error GoTo 0
' Pause
On Error Resume Next
Do
Err.Clear
WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
DoEvents
Loop Until Err.Number = 0
On Error GoTo 0
Application.CutCopyMode = False
ClearClipboard
Set Shp4 = WK2.Shapes(WK2.Shapes.Count)
With Shp4
.Top = WK2.Cells(i + j, 3).MergeArea.Top
.Left = WK2.Cells(i + j, 3).MergeArea.Left + WK2.Cells(i, 3).MergeArea.Width - Shp2.Width
End With
j = j + 2
End With
Next i
End With
End Sub
The API code:
Option Explicit
' Windows API declarations
#If VBA7 Or Win64 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CountClipboardFormats Lib "user32" () As Long
#End If
Public Sub WaitOnClipboard()
Do
DoEvents
' Loop Until IsPicInClipboard
Loop Until IsPicOnClipboard
End Sub
' Wait until PowerPoint shape object is on the Windows clipboard
Public Sub WaitForClipboard()
Do
DoEvents
' Loop Until IsPicInClipboard
Loop Until IsPicOnClipboard
End Sub
Function IsShapeOnClipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
IsShapeOnClipboard = IsClipboardFormatAvailable(&HC216&)
EmptyClipboard
CloseClipboard
End Function
Function IsPicInClipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
IsPicInClipboard = False
If IsClipboardFormatAvailable(2) <> 0 Or _
IsClipboardFormatAvailable(3) <> 0 Or _
IsClipboardFormatAvailable(9) <> 0 Or _
IsClipboardFormatAvailable(14) <> 0 Or _
IsClipboardFormatAvailable(25) <> 0 Or _
IsClipboardFormatAvailable(29) <> 0 Then IsPicInClipboard = True
End Function
' Check if PowerPoint shape object is on the Windows clipboard
Public Function IsPicOnClipboard() As Boolean
Dim lFormat As Long
Dim sName As String
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
Do
lFormat = EnumClipboardFormats(lFormat)
' sName = String(255, 0)
' sName = Space(255)
' GetClipboardFormatName lFormat, sName, Len(sName)
' Debug.Print lFormat, sName
' If sName Like "*PowerPoint 12.0 Internal Shapes*" Then IsPicOnClipboard = True: Exit Do
' If InStr(1, Trim(lFormat), "14", vbTextCompare) > 0 Then IsPicOnClipboard = True: Exit Do
If (lFormat = 2 Or lFormat = 3 Or lFormat = 9 Or lFormat = 14 Or lFormat = 25 Or lFormat = 29) Then IsPicOnClipboard = True: Exit Do
Loop Until lFormat = 0
CloseClipboard
End Function
Public Sub Pause()
Dim t As Double
t = Timer
Do Until Timer - t > 1
DoEvents
Loop
End Sub
Function IsClipboardEmpty() As Boolean
IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function
Public Function ClearClipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Function
Public Sub CopyShape(ItemName As String, ByRef CopyDestination As Worksheet, ByRef PasteDestination As Worksheet)
Call ClearClipboard
ThisWorkbook.Sheets(CopyDestination).Shapes(ItemName).Copy
ThisWorkbook.Sheets(PasteDestination).Paste
Do Until IsClipboardEmpty = False
DoEvents
Loop
End Sub
Function Is_Pic_in_Clipboard() As Boolean
If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Or IsClipboardFormatAvailable(9) <> 0 Then _
Is_Pic_in_Clipboard = True '2=BMP, 14=JPEG, 9=Picture
End Function
Sub ListClipFormats()
Dim Arr, Fmt
Arr = Application.ClipboardFormats
For Each Fmt In Application.ClipboardFormats
Select Case Fmt
Case xlClipboardFormatBIFF Or 8: Debug.Print "Binary Interchange file format for Excel version 2.x"
Case xlClipboardFormatBIFF12 Or 63: Debug.Print "Binary Interchange file format 12"
Case xlClipboardFormatBIFF2 Or 18: Debug.Print "Binary Interchange file format 2"
Case xlClipboardFormatBIFF3 Or 20: Debug.Print "Binary Interchange file format 3"
Case xlClipboardFormatBIFF4 Or 30: Debug.Print "Binary Interchange file format 4"
Case xlClipboardFormatBinary Or 15: Debug.Print "Binary format"
Case xlClipboardFormatBitmap Or 9: Debug.Print "Bitmap format"
Case xlClipboardFormatCGM Or 13: Debug.Print "CGM format"
Case xlClipboardFormatCSV Or 5: Debug.Print "CSV format"
Case xlClipboardFormatDIF Or 4: Debug.Print "DIF format"
Case xlClipboardFormatDspText Or 12: Debug.Print "Dsp Text format"
Case xlClipboardFormatEmbeddedObject Or 21: Debug.Print "Embedded Object"
Case xlClipboardFormatEmbedSource Or 22: Debug.Print "Embedded Source"
Case xlClipboardFormatLink Or 11: Debug.Print "Link"
Case xlClipboardFormatLinkSource Or 23: Debug.Print "Link to the source file"
Case xlClipboardFormatLinkSourceDesc Or 32: Debug.Print "Link to the source description"
Case xlClipboardFormatMovie Or 24: Debug.Print "Movie"
Case xlClipboardFormatNative Or 14: Debug.Print "Native"
Case xlClipboardFormatObjectDesc Or 31: Debug.Print "Object description"
Case xlClipboardFormatObjectLink Or 19: Debug.Print "Object link"
Case xlClipboardFormatOwnerLink Or 17: Debug.Print "Link to the owner"
Case xlClipboardFormatPICT Or 2: Debug.Print "Picture"
Case xlClipboardFormatPrintPICT Or 3: Debug.Print "Print picture"
Case xlClipboardFormatRTF Or 7: Debug.Print "RTF format"
Case xlClipboardFormatScreenPICT Or 29: Debug.Print "Screen Picture"
Case xlClipboardFormatStandardFont Or 28: Debug.Print "Standard Font"
Case xlClipboardFormatStandardScale Or 27: Debug.Print "Standard Scale"
Case xlClipboardFormatSYLK Or 6: Debug.Print "; SYLK"
Case xlClipboardFormatTable Or 16: Debug.Print "; Table"
Case xlClipboardFormatText Or 0: Debug.Print "Text"
Case xlClipboardFormatToolFace Or 25: Debug.Print "Tool Face"
Case xlClipboardFormatToolFacePICT Or 26: Debug.Print "Tool Face Picture"
Case xlClipboardFormatVALU Or 1: Debug.Print "Value"
Case xlClipboardFormatWK1 Or 10: Debug.Print "Workbook"
End Select
Next Fmt
End Sub
Public Sub ListClipboardFormats()
Dim lFormat As Long
Dim sName As String
If OpenClipboard(0&) = 0 Then Exit Sub ' Could not open clipboard
Do
lFormat = EnumClipboardFormats(lFormat)
sName = String(255, 0)
GetClipboardFormatName lFormat, sName, Len(sName)
If Not lFormat = 0 Then Debug.Print lFormat, sName
Loop Until lFormat = 0
EmptyClipboard
CloseClipboard
End Sub
EDIT:
@iinspectable, it is not a normal Copy-Paste issue, but a clipboard timing issue if copy paste is involved in a loop i.e. copy paste done multiple times. Here's an example where the SingleCopyPaste procedure works, but not the MultipleCopyPaste procedure. I hope you get my point now.
Option Explicit
Sub MultipleCopyPaste()
Dim shp As Shape
For Each shp In Sheet1.Shapes
shp.CopyPicture
Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)
Next shp
End Sub
Sub SingleCopyPaste()
Dim shp As Shape
Set shp = Sheet1.Shapes("Arrow")
shp.CopyPicture
Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)
End Sub
解决方案
Here's an example of just retrying the paste if it fails:
Sub Tester()
Dim pic, i As Long
Set pic = Sheet1.Shapes("testPic")
For i = 1 To 100
pic.Copy
PastePicRetry Sheet2.Cells(i, 2)
Next i
End Sub
'paste problem fix
Sub PastePicRetry(rng As Range)
Dim i As Long
Do While i < 20
On Error Resume Next
rng.PasteSpecial
If Err.Number <> 0 Then
Debug.Print "Paste failed", i
DoEvents
i = i + 1
Else
Exit Do
End If
On Error GoTo 0
i = i + 1
Loop
End Sub
这篇关于形状复制粘贴计时问题-Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
