The code below, quoted from China, convert PPT to Word.
Set reference to Microsoft Word XX Object Library
Enjoy
[vba]
Option Explicit
Sub WriteToWord()
Dim aSlide As Slide, MyDoc As New Word.Document, MyRange As Word.Range
Dim aTable As Table, aShape As Shape, TablesCount As Integer, ShapesCount As Integer
Dim i As Word.Paragraph
On Error Resume Next
With MyDoc
.Application.Visible = False
.Application.ScreenUpdating = False
For Each aSlide In ActivePresentation.Slides
For Each aShape In aSlide.Shapes
Set MyRange = .Range(.Content.End - 1, .Content.End - 1)
Select Case aShape.Type
Case msoAutoShape, msoPlaceholder, msoTextBox
If aShape.TextFrame.HasText Then
aShape.TextFrame.TextRange.Copy
MyRange.Paste
With MyRange
.ParagraphFormat.Alignment = wdAlignParagraphLeft
For Each i In MyRange.Paragraphs
If i.Range.Font.Size >= 16 Then
i.Range.Font.Size = 14
Else
i.Range.Font.Size = 12
End If
Next
End With
End If
Case msoPicture
aShape.Copy
MyRange.PasteSpecial DataType:=wdPasteMetafilePicture
ShapesCount = .Shapes.Count
With .Shapes(ShapesCount)
.LockAspectRatio = msoFalse
.Width = Word.CentimetersToPoints(14)
.Height = Word.CentimetersToPoints(6)
.Left = wdShapeCenter
.ConvertToInlineShape
End With
.Content.InsertAfter Chr(13)
Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject
aShape.Copy
MyRange.PasteSpecial DataType:=wdPasteOLEObject
ShapesCount = .Shapes.Count
With .Shapes(ShapesCount)
.LockAspectRatio = msoFalse
.Width = Word.CentimetersToPoints(14)
.Height = Word.CentimetersToPoints(6)
.Left = wdShapeCenter
.ConvertToInlineShape
End With
.Content.InsertAfter Chr(13)
Case msoTable
aShape.Copy
MyRange.Paste
TablesCount = .Tables.Count
With .Tables(TablesCount)
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Range.Font.Size = 11
End With
.Content.InsertAfter Chr(13)
End Select
Next
If aSlide.SlideIndex < ActivePresentation.Slides.Count Then .Content.InsertAfter Chr(12)
.UndoClear ' Clear used memory
Next
With .Content.Find
.ClearFormatting
.Format = True
.Font.Color = wdColorWhite
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
MsgBox "PPT Converted to WORD completed", vbInformation + vbOKOnly, "ExcelHome/ShouRou"
.Application.Visible = True
.Application.ScreenUpdating = True
End With
End Sub
[/vba]