如何从 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

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

How to copy 15 lines from MS word and paste it to each slide in powerpoint slide?

powerpoint

vba

ms-word