[原创并分享]PPT 转 WORD

守柔

应网友要求,做了一个PPT文档转化为WORD文档的小程序,欢迎测试! 1. 功能：

n 对PPT中文本框中的文字、图形、图表、嵌入式对象、表格等，一一写入WORD中，并基本保持原有格式。

n 对其中的白色字体，自动设置为黑色（自动色）

n 对图表和嵌入式对象等，以图片方式粘贴，并切断了链接；图形在WORD中均以14*6厘米的大小、居中和嵌入式格式设置；

n 对表格，按页面大小的100%进行设置，并调整字体为11号；

n 以加载宏的方式可以方便用户调用/加载和卸载。

n 加载时自动向常用工具栏的第一个按钮位置添加名为"PPTtoWord"的命令，并在用户卸载时删除此命令。

2. 存在的问题：

n 仅适用于OFFICEXP及以上版本；如果是2000的版本，请更改并勾选VBE 工具/引用中对于MICROSOFT WORD 9.0 OBJECT LIBRARY.

n 对其中的一些格式,你可以自行添加一些代码

n 受用户PPT文档编辑过程的影响,部分文本框中内容的秩序会有影响.

3. 注意事项:

n 请将PPT中的宏安全性设置为低,如果为非低,请设置为低后重启PPT;

n 请将此加载宏解压于指定文件夹,以便于你的加载调用;建议解压于:"C:\Documents and Settings\username\Application Data\Microsoft\AddIns"文件夹中

n 请在工具/加载宏中,加载此加载宏(PPTtoWord.ppa)

以下代码供参考：

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 .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 '---------------------- 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 '----------------------

eTaqyAm2.rar (11.14 KB, 下载次数: 4328)

2005-9-22 05:54 上传

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

[此贴子已经被作者于2005-9-22 5:54:48编辑过]

konggs

顶，老大的，我相信肯定是好东东。只是平时很少用PPt，如果以后用的话，老大的这个是最好不过的了。

见意：加精！以后用时寻找方便

hpw

HOHO,真棒! 一直在寻找这样的加载程序,老大真是太厉害了.[em02][em02][em02]

我在工作中已经用上了,这里的表格处理的很漂亮哦,对了,有一些地方,还希望守柔有时间的话,能否作一些修改:

1.字体方面,如果PPT中是标题级的话可以对应到WORD中为四号字,除标题外,对应小四号字体;

2.PPT中一页的,对应WORD中为一页;

3.图能否弄成嵌入式的,可以方便修改?

4.转成WORD后,将全文居左,这样看起来会比较整齐.

嘿嘿,[em02][em02]

如意

哇，今天我可找到宝了，狂喜！

太谢谢你了，守柔！

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

wangwei

老大果然强！支持！[em23][em24]

守柔

以下是引用hpw在2005-9-11 19:22:30的发言：

HOHO,真棒! 一直在寻找这样的加载程序,老大真是太厉害了.[em02][em02][em02]

我在工作中已经用上了,这里的表格处理的很漂亮哦,对了,有一些地方,还希望守柔有时间的话,能否作一些修改:

1.字体方面,如果PPT中是标题级的话可以对应到WORD中为四号字,除标题外,对应小四号字体;

2.PPT中一页的,对应WORD中为一页;

3.图能否弄成嵌入式的,可以方便修改?

4.转成WORD后,将全文居左,这样看起来会比较整齐.

嘿嘿,[em02][em02]

请HPW网友运行以下代码：

我不想对于一楼的贴子进行修改，因为它的适用性、通用性也许更好一些。

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 '隐藏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 '----------------------

hpw

噢呵，谢谢老大，这两天工作太多，头脑太晕，还未来得及去测试这个，先下载了！有问题我还会问噢？

感动中。。。。。。

[em02][em02]

henterwu

热烈鼓掌！！！！

dldldl

测试了一下，转换后太凌乱，再一步修改一下，可能会好一些。

tudi6709

大师的作品非同一般，我是一个小菜，不知道如何加载宏，建议解压到。。。。

我电脑第二级文件夹没有？？？？？