求助：paste 如何等待完成后再运行？

sdzylwh

Sub 复制到Excel后输出()



        Dim Excel_Shape As Shape
        Dim i As Integer
        Dim FN As String
        Dim Word, Myword As Object
        Set Word = CreateObject("word.application")
        Set Myword = Word.documents.Open("F:\Xeon\Documents\人事资料\个人档案2017\" & Sheet2.Cells(K, 1))
        Word.Visible = True
        Application.DisplayAlerts = False '从doc到xls的复制过程可能会报错，故加此句
        For i = 1 To Myword.Shapes.Count
           Myword.Shapes(i).Select
           Word.Selection.Copy
           ActiveSheet.Cells(i, 1).Activate
           ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
           Set Excel_Shape = ActiveSheet.Shapes(1) '因为当单个doc中存在图片量过多，均复制到xls中造成数据量过大，
           '这里采用了复制一个进入xls，再另存图片后，立即删除xls中的图片数据，所以遍历时，index永远是1
           Excel_Shape.Copy
           FN = ThisWorkbook.Path & Left(Sheet2.Cells(K, 1), 3) & "" & i & ".jpg"
           With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart



              .Paste  ‘图片较大，运行的时候需要等待粘贴完成，否则保存的图片是空白的，如何处理?????????????
'F8 手动一条条看着执行没有问题，生成的文件都正常，在这儿粘贴的时候如何按的太快或让程序自动执行就会产生空白图片。请指教。谢谢

              FN = ThisWorkbook.Path & Left(Sheet2.Cells(K, 1), Len(Sheet2.Cells(K, 1)) - 4) & "" & i & ".jpg"

              .Export FN ' ThisWorkbook.Path  & i & ".jpg"
              .Parent.Delete '删除第二次复制产生的数据
           End With
           Excel_Shape.Delete '删除第一次复制产生的数据
        Next i

end sub

sy394589008

在最上面定义休眠   Private Dealare sub sleep Lib "Kernel32"(Byval dwMilliseconds as long )。然后在程序粘贴后面加上  【 Sleep 500】   粘贴后程序休眠500ms，数字自己在选择看什么时候再运行，

sdzylwh

加入sleep 2000后依然是空白图片呢？何解？请指教

sdzylwh

哪位大侠给予解惑