如何把每6段转换成一张ppt，保留原文字的颜色下划线和粗体格式

zzpsx

每6段转换成一张ppt，保留原文字的颜色下划线和粗体格式.zip (18.81 KB, 下载次数: 0)

2024-11-13 13:07 上传

点击文件名下载附件

我自己写的代码，不能粗体，也不能每页六段，只能每页一段。请高手斧正

Sub 按段转()
  
    Dim oPPT As Object
    Dim oPPTPres As Object
    Dim oSlide As Object
    Dim strText As String
    Dim arrSections As Variant
    Dim strSection As String
    Dim i As Integer
    Dim j As Integer
    Dim leftPosition As Single
    Dim topPosition As Single
    Dim slideWidth As Single
    Dim slideHeight As Single
    Dim a As Object ' Shape 对象
    Dim wordDoc As Document
    Dim wordRange As Range
    Dim pptTextRange As Object
    Dim currentPara As Range
   
    ' 获取当前活动的 Word 文档
    Set wordDoc = ActiveDocument
   
    ' 创建 PowerPoint 应用实例
    Set oPPT = CreateObject("PowerPoint.Application")
    oPPT.Visible = True

    ' 创建新的 PowerPoint 演示文稿
    Set oPPTPres = oPPT.Presentations.Add

    ' 遍历 Word 文档中的段落（假设每个段落对应一个幻灯片）
    For i = 1 To wordDoc.Paragraphs.count
        Set currentPara = wordDoc.Paragraphs(i).Range
        
        ' 检查段落是否为空
        If Trim(currentPara.text) <> vbNullString Then
            ' 在 PowerPoint 中添加新幻灯片
            Set oSlide = oPPTPres.Slides.Add(i, 1) ' 添加标题幻灯片版式

            ' 自定义文本框位置
            leftPosition = 20 ' 从左边距 20 磅
            topPosition = 10  ' 从上边距 10 磅
            slideWidth = oSlide.Master.Width - leftPosition * 2 ' 根据幻灯片宽度调整
            slideHeight = oSlide.Master.Height - topPosition * 2 ' 根据幻灯片高度调整

            ' 添加文本框
            Set a = oSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                               Left:=leftPosition, Top:=topPosition, Width:=slideWidth, Height:=slideHeight)
            
            ' 设置文本内容
            a.TextFrame.TextRange.text = currentPara.text
            
            ' 遍历 Word 文档中的每个字符，并将其格式应用到 PowerPoint 中
            For j = 1 To currentPara.Characters.count
                Set wordRange = currentPara.Characters(j)
               
                ' 设置字体颜色
                a.TextFrame.TextRange.Characters(j).Font.Color.RGB = wordRange.Font.Color
               
                ' 设置下划线
                If wordRange.Font.Underline <> wdUnderlineNone Then
                    a.TextFrame.TextRange.Characters(j).Font.Underline = msoTrue
                End If
            Next j

            ' 设置字体和大小
            a.TextFrame.TextRange.Font.Name = "Arial" ' 可以根据需要调整字体
            a.TextFrame.TextRange.Font.Size = 40 ' 设置字体大小
        End If
    Next i

    ' 删除 PPT 中的空形状和特定文本的形状
    For Each oSlide In oPPTPres.Slides
        For j = oSlide.Shapes.count To 1 Step -1
            Set a = oSlide.Shapes(j)
            If a.HasTextFrame And Len(a.TextFrame.TextRange.text) = 0 Then
                a.Delete
            ElseIf a.HasTextFrame And a.TextFrame.TextRange.text = "单击此处添加副标题" Then
                a.Delete
            End If
        Next j
    Next oSlide

    ' 清理
    Set oSlide = Nothing
    Set oPPTPres = Nothing
    Set oPPT = Nothing
End Sub

zzpsx

顶一下，请高手点石成金。