运用VBA将Word文档内容发送至PowerPoint的一个实例

楼主
0Mouse

Q：如何运用VBA将示例Word文档的内容发送至PowerPoint呢？
示例Word文档内容部分截图：

对应的预期幻灯片效果：

A：代码如下：

Const ppLayoutText = 2 '声明“标题和内容”版式常量
Sub 运用VBA将Word文档内容发送至PowerPoint()
Dim pptPre As Object '指代演示文稿的变量
Dim pptSld As Object '指代幻灯片的变量
Dim para As Paragraph '段落变量
Dim lnum As Long '大纲级别为1级的段落数计数变量
Dim pCount As Byte '标记幻灯片第2个占位符的段落数
Dim ArrLevel() As Byte '动态数组变量，记录第2个占位符各段落的缩进级别
Dim idx As Byte '循环变量
With CreateObject("PowerPoint.Application") '引用PowerPoint应用程序
Set pptPre = .presentations.Add '新建演示文稿并赋值给pptPre变量
For Each para In ActiveDocument.Paragraphs '循环分析Word文档的每一个段落
With para '引用循环到的段落对象
Select Case .OutlineLevel '判断段落的大纲级别
Case wdOutlineLevel1 '如果是1级
lnum = lnum + 1 '计数变量+1
'新建“标题和内容”版式的幻灯片并赋值给pptSld变量
Set pptSld = pptPre.slides.Add(lnum, ppLayoutText)
'在新建幻灯片的标题占位符内放入当前段落除最后一个字符（段落标记）以外的内容
pptSld.Shapes(1).TextFrame.TextRange.Text = Left(.Range.Text, Len(.Range.Text) - 1)
Case wdOutlineLevel2, wdOutlineLevel3 '如果是2级或3级
With pptSld.Shapes(2).TextFrame.TextRange '引用第2个占位符
pCount = .Paragraphs.Count '标记占位符内的段落总数
If pCount Then '如果段落数不为0，也即占位符内有内容
ReDim ArrLevel(1 To pCount) '重新声明数组，并指定其维度的大小
'通过循环将占位符内各段落的缩进级别记录在数组变量中
For idx = 1 To pCount
ArrLevel(idx) = .Paragraphs(idx).IndentLevel
Next idx
End If
.Text = .Text & para.Range.Text '将当前循环到的段落文本追加到占位符末尾
'通过循环恢复追加文本前占位符中各段落的缩进级别
For idx = 1 To pCount
.Paragraphs(idx).IndentLevel = ArrLevel(idx)
Next idx
'设置追加段落（此时占位符内的最后一个段落）的缩进级别为当前循环到的段落的大纲级别-1
.Paragraphs(idx).IndentLevel = para.OutlineLevel - 1
pCount = 0 '重置标记段落数的变量
End With
End Select
End With
Next para
Erase ArrLevel '清空数组变量
Set pptSld = Nothing '清空对象变量pptSld
Set pptPre = Nothing '清空对象变量pptPre
.Visible = True '令PowerPoint程序窗口可见
End With
MsgBox "完毕！", vbInformation, "xqoa" '弹出消息框提示处理完毕
End Sub

示例附件：

运用VBA将Word文档内容发送至PowerPoint的一个实例.rar