[英]How to copy 15 lines from MS word and paste it to each slide in powerpoint slide?
I'm trying to copy first 15 lines from Word and paste it to Slide(1) in PowerPoint, next 15 lines to Slide(2).....repeat until all texts are copied into PowerPoint.我正在尝试从 Word 中复制前 15 行并将其粘贴到 PowerPoint 中的 Slide(1),接下来的 15 行到 Slide(2).....重复,直到所有文本都复制到 PowerPoint 中。 There is only one textbox on each slide.每张幻灯片上只有一个文本框。 I couldn't figure out how to loop so tried to do in not cool way as following, but in this way, second 15 lines are copied in both Slide(1) and (2).我不知道如何循环,所以尝试以不酷的方式进行如下操作,但通过这种方式,第二个 15 行被复制到 Slide(1) 和 (2) 中。 Is there any good way?有什么好办法吗?
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结束子
Here is your macro with a loop.这是带有循环的宏。 There is also a DoEvents loop to allow the operating system time to paste.还有一个 DoEvents 循环,允许操作系统有时间进行粘贴。 Otherwise the text doesn't go into the selected placeholder.否则文本不会进入选定的占位符。 Depending on your computer's speed, you may have to increase the second number in the DoEvents loop:根据您计算机的速度,您可能需要增加 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.