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

[lucas]

Thanks Emily, that works nicely. Don't forget to mention to new users that a reference has to be set to the Microsoft Word vXX object library....

[lucas]

Please consider submitting this to our Knowledgebase. Access with Kbase link at the top of the page.

[Emily]

I think I am not the appropriate person to submit as KB.
I just want to share the writer's experinence.

[lucas]

Submit the entry and give them credit for it in the discussion section of the entry......

[Emily]

Informed orginial writer and submitted with ppa attachment

Code added

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

Regards.
Emily

[lucas]

Hi Emily,
For some reason this is not showing up in the approvers forum as submitted. The forum has undergone a recent upgrade and that could be part of it.

It is also possible that you left it in wip (work in progress) at the bottom of the submit page. Look for a drop down box and select "for approval" then save .......please disregard if you've already done this but let me know so I can do something about it.
Thanks,

[Emily]

Sorry,
I left it as WIP previously

[lucas]

Sorry Emily, its still wip and I can't approve it until you set it to for approval and click save at the bottom of the entry....will approve it as I have already looked it over and it looks good.

Might tell users how to put it in the directory where it can be found as an addin. Works great though and I look forward to approving it for you.