ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 171948|回复: 281

[原创并分享]PPT 转 WORD

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2005-9-11 10:33 | 显示全部楼层 |阅读模式
应网友要求,做了一个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, 下载次数: 4320)

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

[原创并分享]PPT 转 WORD

[原创并分享]PPT 转 WORD

[原创并分享]PPT 转 WORD

[原创并分享]PPT 转 WORD

FODlwjnK.zip

13.02 KB, 下载次数: 2725

[原创并分享]PPT 转 WORD

评分

6

查看全部评分

TA的精华主题

TA的得分主题

发表于 2005-9-11 11:01 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

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

见意:加精!以后用时寻找方便

TA的精华主题

TA的得分主题

发表于 2005-9-11 19:22 | 显示全部楼层

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

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

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

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

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

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

嘿嘿,[em02][em02]

TA的精华主题

TA的得分主题

发表于 2005-9-12 13:15 | 显示全部楼层

哇,今天我可找到宝了,狂喜!

太谢谢你了,守柔!

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

TA的精华主题

TA的得分主题

发表于 2005-9-12 14:05 | 显示全部楼层
老大果然强!支持![em23][em24]

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-9-12 16:38 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
以下是引用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 '----------------------

TA的精华主题

TA的得分主题

发表于 2005-9-12 19:31 | 显示全部楼层

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

感动中。。。。。。

[em02][em02]

TA的精华主题

TA的得分主题

发表于 2005-9-12 20:24 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
热烈鼓掌!!!!

TA的精华主题

TA的得分主题

发表于 2005-9-15 18:06 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
测试了一下,转换后太凌乱,再一步修改一下,可能会好一些。

TA的精华主题

TA的得分主题

发表于 2005-9-17 07:51 | 显示全部楼层

[讨论]

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

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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-7-12 20:32 , Processed in 0.052734 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表