发帖
雷达卡
PPTtoWord.rar
(11.14 KB, 需要: 1 个论坛币)
本附件包括：- PPTtoWord.ppa
1. 功能：
对PPT中文本框中的文字、图形、图表、嵌入式对象、表格等，一一写入WORD中，并基本保持原有格式。 对其中的白色字体，自动设置为黑色（自动色） 对图表和嵌入式对象等，以图片方式粘贴，并切断了链接；图形在WORD中均以14*6厘米的大小、居中和嵌入式格式设置； 对表格，按页面大小的100%进行设置，并调整字体为11号； 以加载宏的方式可以方便用户调用/加载和卸载。 加载时自动向常用工具栏的第一个按钮位置添加名为"PPTtoWord"的命令，并在用户卸载时删除此命令。 2. 存在的问题： 仅适用于OFFICEXP及以上版本；如果是2000的版本，请更改并勾选VBE 工具/引用中对于MICROSOFT WORD 9.0 OBJECT LIBRARY. 对其中的一些格式,你可以自行添加一些代码 受用户PPT文档编辑过程的影响,部分文本框中内容的秩序会有影响. 3. 注意事项: 请将PPT中的宏安全性设置为低,如果为非低,请设置为低后重启PPT; 请将此加载宏解压于指定文件夹,以便于你的加载调用;建议解压于:"C:\Documents and Settings\username\Application Data\Microsoft\AddIns"文件夹中 请在工具/加载宏中,加载此加载宏(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 '----------------------
京公网安备 11010802022788号
