[原创并分享]PPT 转 WORD

1261181315a

konggs 发表于 2005-9-11 11:01
顶，老大的，我相信肯定是好东东。只是平时很少用PPt，如果以后用的话，老大的这个是最好不过的了。见意：加 ...

谢谢楼主分享

欧阳11

赞一个！先收藏需要时提出！

weiyingde

整理一下，便于阅读和借用。
Option Explicit
Sub WritePptToWord()
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
'----------------------

weiyingde

守柔 发表于 2005-9-12 16:38
请HPW网友运行以下代码：
我不想对于一楼的贴子进行修改，因为它的适用性、通用性也许更好一些。
Opt ...

也进行重新排版，便于阅读、理解、调用。
谢谢守版的奉献。
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 '----------------------

linyh1742595842

谢谢楼主分享

abigailluck

大神都是这么优秀，谢谢分享，好好学习

任我小行

我是菜鸟的菜鸟，不会用

shenjianrong163

weiyingde 发表于 2017-4-18 10:55
也进行重新排版，便于阅读、理解、调用。
谢谢守版的奉献。
Sub WriteToWord()

你的代码是否少了两行?我加上这两行运行结束后为什么没有出现Word文档呢?
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
        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
     End If
      MsgBox "PPT转换为WORD文档已经结束,请校对和进一步编辑!", vbInformation + vbOKOnly, "ExcelHome/ShouRou"
      .Application.Visible = True '显示Word应用程序
      .Application.ScreenUpdating = True '恢复WORD的屏幕更新
End With
End Sub

baobao5_8

看着很酷炫，但我不会用，哈哈哈

panxiong2006

找了好几个小时怎么激活PPT加载宏的方法，终于找到了