[原创并分享]PPT 转 WORD

老慢羊

这个东东对我太有用了，我时常要处理别的公司或个人提供的PPT文档，直接用PPT格式打印太浪费，发送邮件时也常因PPT文档太大而影响接收，因此我常需要花不少时间把PPT转成WORD，有了你这个我可省事了。

zaojiashi75

顶。

试试　看。

前两天还有人问我这事呢。

lisa.peng

崇拜中~~~~

liuyee

我是2003的可是怎么都打开不了啊？

强烈建议楼主将次代码升级啊！！！

yxsyjin

高手[em12]

cytology

运行不了？？？

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

chenxue003

为何我下载不了？

likeu

下来看看什么东东，也许有用，只是平时很少用PPT。

gongqiulin

认认真真学习一下！

sunnyskylyg

好东东，谢谢啦