'
 ' Set Reference to Microsoft Word 11.0 Object Library
 '---------------------------------------------------------------------------------------
 ' Module    : Module1
 ' DateTime  : 29/4/2006 22:53
 ' Author      : Re-Built by Emily
 ' Tested in Office 2003
 '
 ' Orginial Created By ShouRou (Chinese Word MVP) 2005-9-22
 ' Windows NT Word: 10.0 Language: 2052
 ' http://club.excelhome.net/dispbbs.asp?boardid=23&id=121653
 '
 ' Purpose   : Convert PPT to Word Document
 '---------------------------------------------------------------------------------------
 '
 
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 
         ' Change white font to black color
        With .Content.Find 
            .ClearFormatting 
            .Format = True 
            .Font.Color = wdColorWhite 
            .Replacement.Font.Color = wdColorAutomatic 
            .Execute Replace:=wdReplaceAll 
        End With 
        MsgBox "PPT Converted to WORD completed, Please check and save document", vbInformation + vbOKOnly, "ExcelHome/ShouRou" 
        .Application.Visible = True 
        .Application.ScreenUpdating = True 
    End With 
End Sub 
 
Sub Auto_Open() ' Add PPTtoWord to Tool Bar when Powerpoint start
    Dim MyControl As CommandBarControl 
    On Error Resume Next 
    Application.CommandBars("Standard").Controls("PPTtoWord").Delete 
    Set MyControl = Application.CommandBars("Standard").Controls.Add(Before:=1) 
    With MyControl 
        .Caption = "PPTtoWord" 
        .FaceId = 567 ' Word Icon
        .Enabled = True 
        .Visible = True 
        .Width = 100 
        .OnAction = "WriteToWord" 
        .Style = msoButtonIconAndCaption 
    End With 
End Sub 
 
Sub Auto_Close() ' Delete PPTtoWord from Tool Bar when Powerpoint close
    On Error Resume Next 
    Application.CommandBars("Standard").Controls("PPTtoWord").Delete 
End Sub