香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 11th Apr 2006, 10:00 AM | Office Application, PowerPoint | (10303 Reads)

轉換 PPT 至 Word 文件

PowerPoint 轉換爲 WORD文件

PPT 轉 WORD

Option Explicit

' Set reference to Microsoft Word XX Object Library
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    '隱藏WORD程式視窗
        .Application.ScreenUpdating = False    '關閉WORD螢幕更新以加快運行
        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 圖層類型
                    '自選圖形,文本框等
                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    '設置為14號字體
                                Else
                                    i.Range.Font.Size = 12    '設置為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)    '寬為14釐米
                        .Height = Word.CentimetersToPoints(6)    '高為6釐米
                        .Left = wdShapeCenter    '居中
                        .ConvertToInlineShape    '轉換為嵌入式圖片物件,以利排版
                    End With
                    .Content.InsertAfter Chr(13)    '插入一個段落標記
                    'Case為圖表物件和嵌入式物件等時
                Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject
                    aShape.Copy    '複製
                    MyRange.PasteSpecial DataType:=wdPasteOLEObject
                    ShapesCount = .Shapes.Count    '取得文檔中的圖形數量
                    With .Shapes(ShapesCount)
                        .LockAspectRatio = msoFalse    '不鎖定縱橫比
                        .Width = Word.CentimetersToPoints(14)    '寬為14釐米
                        .Height = Word.CentimetersToPoints(6)    '高為6釐米
                        .Left = wdShapeCenter    '居中
                        .ConvertToInlineShape    '轉換為嵌入式圖片物件,以利排版
                    End With
                    .Content.InsertAfter Chr(13)    '插入一個段落標記
                Case msoTable    'Case表格時
                    aShape.Copy    '複製
                    MyRange.Paste    '粘貼
                    TablesCount = .Tables.Count    '取得文檔中的表格數量
                    With .Tables(TablesCount)    '表格物件
                        .PreferredWidthType = wdPreferredWidthPercent      '百分比
                        .PreferredWidth = 100      '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 '清空撤銷,以減少記憶體支出
        Next
        '替換白色字體為自動色(黑色)
        With .Content.Find
            .ClearFormatting    '清除格式
            .Format = True    '格式查找
            .Font.Color = wdColorWhite    '白色字體
            .Replacement.Font.Color = wdColorAutomatic    '自動色
            .Execute Replace:=wdReplaceAll    '全部替換
        End With
        MsgBox "PPT轉換為WORD文檔已經結束,請校對和進一步編輯!", vbInformation + vbOKOnly, "ExcelHome/ShouRou"
        .Application.Visible = True    '顯示Word應用程式
        .Application.ScreenUpdating = True    '恢復WORD的螢幕更新
    End With
End Sub