[原创并分享]PPT 转 WORD

taigaoxiao

如果想把选定文本（甚至整篇文档）中的所有域括号全部转换成普通大括号，这个代码是不是简单改进一下就可以了吧？

zaobaoying

的确比里面的好用多啊～～～这样看起来更顺眼啊～～嘿嘿～～

mofei

谢谢版主！

jarry201

找到宝了[em17]谢谢老大[em24]

xwjsyyx

首先感谢守柔版主为我们提供了学习的机会！
我把守柔版主您的原代码整理了一下，但问题很多！希望守柔版主在赐教一次，帮助我把您的原代码整理好！以便进一步学习！
这是我整理的，有很多低级错误，请不要见笑！

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
   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 '粘贴
                        End If
                        'Case为图表对象\图片对象等时
                    Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject, 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 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

    Next
    '替换白色字体为自动色(黑色)
                        With
                            .Content
                            .Find.Clear
                            Formatting '清除格式
                            .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

                            '----------------------
Sub Auto_Open() '加载时在常用工具栏中添加一个命令
    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 '图标
        .Enabled = True '可用
        .Visible = True '显示
        .Width = 100 '宽度
        .OnAction = "WriteToWord" '运行指定的过程
        .Style = msoButtonIconAndCaption '显示的方式图标+标题
    End With
End Sub

'----------------------
Sub Auto_Close()
    '卸载时删除此命令
    On Error Resume Next
    Application.CommandBars("Standard" ).Controls("PPTtoWord" ).Delete
End Sub
'----------------------

hao123

我也收藏了一个同类程序,与大家分享

Aqmx3ulc.rar (19.79 KB, 下载次数: 116)

2008-4-9 10:58 上传

点击文件名下载附件
[原创并分享]PPT 转 WORD

bearbearbear

To xwjsyyx：

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
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 msoAutoShape, msoPlaceholder, msoTextBox 'Case 图层类型 '自选图形,文本框等
               If aShape.TextFrame.HasText Then '如果文本框中包含文字
               aShape.TextFrame.TextRange.Copy '将其中的文字区域复制
               MyRange.Paste '粘贴
               End If
        Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject, 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 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
 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

[此贴子已经被作者于2008-4-9 12:04:35编辑过]

xwjsyyx

谢谢！！！感谢bearbearbear朋友

melody_xu

希望我能用上 呵呵

ytchun

非常感谢，可以大大提高效率了。