I'm trying to turn a Microsoft Word Document into a Powerpoint Presentation. I have tried pasting as a picture to keep the same format as the Word Document, using the link below as a reference, as pasting normally was causing major formatting issues with pictures and texts spread out across the whole slide. However pasting using mySlide.CommandBars.ExecuteMso "PasteAsPicture"
, it sometimes misses pictures and text, or copies and pastes it twice and when pasting tables the formatting is all off. I have tried slowing the pasting down but that also did not seem to work. Does the community have ideas?
How to Copy/Paste text box from MS Word to Powerpoint slide?
Sub WordToPowerPoint()
Dim rgePages As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
On Error Resume Next
For Each oCC In ActiveDocument.ContentControls
If oCC.Title = "FilePath12" Then
fPath = oCC.Range.Text
End If
Next oCC
Set pptApp = CreateObject("PowerPoint.Application")
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
If err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Set myPresentation = PowerPointApp.presentations.Add
a = ActiveDocument.BuiltInDocumentProperties("Number of Pages")
For x = 1 To a
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=x
Set rgePages = Selection.Range
rgePages.End = Selection.Bookmarks("\Page").Range.End
rgePages.Select
On Error Resume Next
Selection.Copy
Selection.CopyFormat
Application.ScreenUpdating = False
Set mySlide = myPresentation.Slides.Add(x, 12)
Set mySlide = myPresentation.Slides(x)
mySlide.Select
mySlide.ApplyTheme fPath
pptApp.CommandBars.ExecuteMso "PasteAsPicture"
Dim time1, time2
time1 = Now
time2 = Now + TimeValue("0:00:01")
Do Until time1 >= time2
DoEvents
time1 = Now()
Loop
Next x
End Sub