- html - 出于某种原因,IE8 对我的 Sass 文件中继承的 html5 CSS 不友好?
- JMeter 在响应断言中使用 span 标签的问题
- html - 在 :hover and :active? 上具有不同效果的 CSS 动画
- html - 相对于居中的 html 内容固定的 CSS 重复背景?
我正在使用 Windows 10 Enterprise 64 位、Office 2016 Pro 64 位。我正在尝试将 2 个形状从一个工作表复制到另一个工作表。
以下 API 代码有时有效,但大多数情况下它会为复制或粘贴(剪贴板计时问题)拍摄错误 1004。我尝试过使用不同的解决方案,例如计时器、等待、API 等,但大多数时候看起来很慢而且有问题!
我也试图将图像粘贴到每个合并单元格的两端。我还附上了a sample file供检查。
我不记得了,但我在某处读到,如果我创建单独的复制和粘贴功能/程序,那么它可能会解决问题,但不确定!
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
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
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
关于excel - 形状复制粘贴时间问题 - Excel VBA,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/60579662/
关闭。这个问题是off-topic .它目前不接受答案。 想要改进这个问题? Update the question所以它是on-topic用于堆栈溢出。 关闭 12 年前。 Improve thi
我有一个动态网格,其中的数据功能需要正常工作,这样我才能逐步复制网格中的数据。假设在第 5 行中,我输入 10,则从第 6 行开始的后续行应从 11 开始读取,依此类推。 如果我转到空白的第一行并输入
我有一个关于我的按钮消失的问题 我已经把一个图像作为我的按钮 用这个函数动画 function example_animate(px) { $('#cont
我有一个具有 Facebook 连接和经典用户名/密码登录的网站。目前,如果用户单击 facebook_connect 按钮,系统即可运行。但是,我想将现有帐户链接到 facebook,因为用户可以选
我有一个正在为 iOS 开发的应用程序,该应用程序执行以下操作 加载和设置注释并启动核心定位和缩放到位置。 map 上有很多注释,从数据加载不会花很长时间,但将它们实际渲染到 map 上需要一段时间。
我被推荐使用 Heroku for Ruby on Rails 托管,到目前为止,我认为我真的会喜欢它。只是想知道是否有人可以帮助我找出问题所在。 我按照那里的说明在该网站上创建应用程序,创建并提交
我看过很多关于 SSL 错误的帖子和信息,我自己也偶然发现了一个。 我正在尝试使用 GlobalSign CA BE 证书通过 Android WebView 访问网页,但出现了不可信错误。 对于大多
我想开始使用 OpenGL 3+ 和 4,但我在使用 Glew 时遇到了问题。我试图将 glew32.lib 包含在附加依赖项中,并且我已将库和 .dll 移动到主文件夹中,因此不应该有任何路径问题。
我已经盯着这两个下载页面的源代码看了一段时间,但我似乎找不到问题。 我有两个下载页面,一个 javascript 可以工作,一个没有。 工作:http://justupload.it/v/lfd7不是
我一直在使用 jQuery,只是尝试在单击链接时替换文本字段以及隐藏/显示内容项。它似乎在 IE 中工作得很好,但我似乎无法让它在 FF 中工作。 我的 jQuery: $(function() {
我正在尝试为 NDK 编译套接字库,但出现以下两个错误: error: 'close' was not declared in this scope 和 error: 'min' is not a m
我正在使用 Selenium 浏览器自动化框架测试网站。在测试过程中,我切换到特定的框架,我们将其称为“frame_1”。后来,我在 Select 类中使用了 deselectAll() 方法。不久之
我正在尝试通过 Python 创建到 Heroku PostgreSQL 数据库的连接。我将 Windows10 与 Python 3.6.8 和 PostgreSQL 9.6 一起使用。 我从“ht
我有一个包含 2 列的数据框,我想根据两列之间的比较创建第三列。 所以逻辑是:第 1 列 val = 3,第 2 列 val = 4,因此新列值什么都没有 第 1 列 val = 3,第 2 列 va
我想知道如何调试 iphone 5 中的 css 问题。 我尝试使用 firelite 插件。但是从纵向旋转到横向时,火石占据了整个屏幕。 有没有其他方法可以调试 iphone 5 中的 css 问题
所以我有点难以理解为什么这不起作用。我正在尝试替换我正在处理的示例站点上的类别复选框。我试图让它做以下事情:未选中时以一种方式出现,悬停时以另一种方式出现(选中或未选中)选中时以第三种方式出现(而不是
Javascript CSS 问题: 我正在使用一个文本框来写入一个 div。我使用以下 javascript 获取文本框来执行此操作: function process_input(){
你好,我很难理解 P、NP 和多项式时间缩减的主题。我试过在网上搜索它并问过我的一些 friend ,但我没有得到任何好的答案。 我想问一个关于这个话题的一般性问题: 设 A,B 为 P 中的语言(或
你好,我一直在研究 https://leetcode.com/problems/2-keys-keyboard/并想到了这个动态规划问题。 您从空白页上的“A”开始,完成后得到一个数字 n,页面上应该
我正在使用 Cocoapods 和 KIF 在 Xcode 服务器上运行持续集成。我已经成功地为一个项目设置了它来报告每次提交。我现在正在使用第二个项目并收到错误: Bot Issue: warnin
我是一名优秀的程序员,十分优秀!