Powerpoint to Word

[Emily]

The code below, quoted from China, convert PPT to Word.
Set reference to Microsoft Word XX Object Library
Enjoy

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