我使用以下代码创建了一个小程序,将图片从一张工作表传输到另一张工作簿中。
Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
If pictureNo = 0 Then Exit Sub
Sheets(srcSht).Select
ActiveSheet.Unprotect
ActiveSheet.pictures("Picture " & pictureNo).Select
'ActiveSheet.Shapes.Range(Array("Picture " & pictureNo)).Select
Selection.Copy
Sheets(dstSht).Select
Range(insertWhere).Select
ActiveSheet.Paste
'== rename to correspond to the problem number
Selection.Name = "Picture " & p
End Sub
这很好用。但是,当我将例程放在一个更大的工作簿中时,我在行中遇到以下错误:Activesheet.paste
:
Worksheet类的粘贴方法失败
该代码适用于多个程序执行。
非常感谢任何帮助。
答案 0 :(得分:1)
试试这个:
Sub transferPicturesPAPER_EXAM(pictureNo As Long, _
p As Integer, srcSht As String, _
dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
Dim pic As Picture
If pictureNo = 0 Then Exit Sub
Application.EnableEvents = False
Sheets(srcSht).Unprotect
Set pic = Sheets(srcSht).Pictures("Picture " & pictureNo)
pic.Copy
Sheets(dstSht).Activate
Sheets(dstSht).Range(insertWhere).Select
Sheets(dstSht).Paste
'== rename to correspond to the problem number
Selection.Name = "Picture " & p
Application.EnableEvents = True
End Sub
答案 1 :(得分:0)
试试这个:
Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
Dim shpPictureToCopyAs Shape
If pictureNo = 0 Then Exit Sub
With Sheets(srcSht)
.Unprotect
Set shpPictureToCopy= .Shapes(pictureNo).Duplicate
shpPictureToCopy.Cut
End With
Sheets(dstSht).Range(insertWhere).PasteSpecial (xlPasteAll)
End Sub
我建议在主程序中禁用和启用事件和屏幕更新,从中调用此程序。否则,您可以在不想要的时候启用它们。像这样:
Sub MainProcedure() 'your sub name
Application.EnableEvents = False
Application.ScreenUpdating = False
Call transferPicturesPAPER_EXAM(1, 1, "Sheet1", "Sheet2", "A20") 'with your variables as arguments of course
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
答案 2 :(得分:0)
时间延迟产生了奇怪的结果。在某些情况下,一些照片被粘贴,而在其他情况下,它们并没有被粘贴。非常不一致的结果。
在子程序的最开始重新定位Application.wait ...代码 - 多次运行程序 - 完美地工作
永远不会猜到这个解决方案。 感谢所有提出解决方案的人。
答案 3 :(得分:0)
我也经常遇到这个问题。但是您不能等待每张图片3秒,这太长了。我正在处理1000张照片,它将永远拍摄。
问题的核心是Excel首先复制到Windows剪贴板,这很慢。
如果您尝试在剪贴板上贴上Pic之前粘贴,则会出错。
因此,大量复制需要一些小的步骤:
以下是代码(适用于Excel 64位):
Option Explicit
'Does the clipboard contain a bitmap/metafile?
Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal Hwnd As LongPtr) As Long
'clear clipboard
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr 'wformat as long ?
'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'for waiting
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Clear_Clipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Application.CutCopyMode = False
End Sub
Sub PastePic(Pic As Shape)
Dim Rg As Range
Dim T#
Dim Ligne&: Ligne = 5
Dim Sh_Vendeur As Worksheet
Set Sh_Vendeur = ThisWorkbook.Sheets(1)
Clear_Clipboard
Pic.Copy
Set Rg = Sh_Vendeur.Cells(Ligne, 2)
'wait until the clipboard gets a pic, but not over 3 seconds (avoid infinite loop)
T = Timer
Do
Waiting (2)
Loop Until Is_Pic_in_Clipboard Or Timer - T > 0.3
'Rg.Select
'Rg.PasteSpecial
Sh_Vendeur.Paste Destination:=Rg 'paste to a range without select
End Sub
Sub Waiting(ByVal Mili_Seconds&)
Sleep Mili_Seconds
End Sub
Function Is_Pic_in_Clipboard() As Boolean
If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Then Is_Pic_in_Clipboard = True '2-14 =bitmap et Picture JPEG
End Function