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