如何从 MS word 复制 15 行并将其粘贴到 powerpoint 幻灯片中的每张幻灯片？

Question

我正在尝试从 Word 中复制前 15 行并将其粘贴到 PowerPoint 中的 Slide(1)，接下来的 15 行到 Slide(2).....重复，直到所有文本都复制到 PowerPoint 中。 每张幻灯片上只有一个文本框。 我不知道如何循环，所以尝试以不酷的方式进行如下操作，但通过这种方式，第二个 15 行被复制到 Slide(1) 和 (2) 中。 有什么好办法吗？

Sub test()
Dim pptApp As Object
Dim pptPres As Object
Dim folderPath As String, file As String
Dim shpTextBox As Object

With ActiveDocument
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
    Selection.Cut
End With

Set pptApp = CreateObject("PowerPoint.Application")

folderPath = ActiveDocument.Path & Application.PathSeparator
file = "test.pptx"

pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(folderPath & file)

Set shpTextBox = pptPres.Slides(1).Shapes(1)
shpTextBox.Select

pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"

With ActiveDocument
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
    Selection.Cut
End With

pptPres.Slides(2).Select
Set shpTextBox = pptPres.Slides(2).Shapes(1)
shpTextBox.Select

pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"

结束子

Answer 1

这是带有循环的宏。 还有一个 DoEvents 循环，允许操作系统有时间进行粘贴。 否则文本不会进入选定的占位符。 根据您计算机的速度，您可能需要增加 DoEvents 循环中的第二个数字：

Sub CutWordPastePP()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim folderPath As String, file As String
    Dim shpTextBox As Object

    Set pptApp = CreateObject("PowerPoint.Application")
    folderPath = ActiveDocument.Path & Application.PathSeparator
    file = "test.pptx"
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Open(folderPath & file)
    x = 1
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst

    Do Until ActiveDocument.Content.Characters.Count = 1
        With Selection
            .HomeKey Unit:=wdStory, Extend:=wdMove
            .MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
            .Cut
        End With
        With pptPres
            .Slides(x).Select
            .Slides(x).Shapes(1).Select
        End With
        pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"
        For y = 1 To 6
            DoEvents
        Next y
        x = x + 1
    Loop
End Sub