Как скопировать 15 строк из MS Word и вставить его в каждый слайд в слайде PowerPoint? - PullRequest
Новая
       41

Как скопировать 15 строк из MS Word и вставить его в каждый слайд в слайде PowerPoint?

0 голосов
/ 28 марта 2020

Я пытаюсь скопировать первые 15 строк из Word и вставить их в слайд (1) в PowerPoint, следующие 15 строк в слайд (2) ..... повторять, пока все тексты не будут скопированы в PowerPoint. На каждом слайде есть только одно текстовое поле. Я не мог понять, как l oop, поэтому попытался сделать это не круто, как показано ниже, но таким образом, вторые 15 строк копируются как в слайд (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"

End Sub

1 Ответ

0 голосов
/ 30 марта 2020

Вот ваш макрос с al oop. Существует также DoEvents l oop, позволяющий операционной системе вставлять время. В противном случае текст не go в выбранный заполнитель. В зависимости от скорости вашего компьютера, вам может потребоваться увеличить второе число в DoEvents l oop: 

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
...