word按照空行转换ppt代码求完善

zzpsx

以下代码，生成的ppt文本框溢出了，文本框中的空行需要删除。

Sub CreatePPTFromWordEmptyLines()
Rem 按空行word转换成ppt
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim para As Paragraph
    Dim i As Integer
    Dim slideIndex As Integer
    Dim content As String

    ' 创建PowerPoint应用
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
        pptApp.Visible = True
    End If
    On Error GoTo 0

    ' 创建新的PowerPoint演示文稿
    Set pptPres = pptApp.Presentations.Add
    slideIndex = 1

    ' 初始化变量
    content = ""

    ' 遍历Word文档中的每个段落
    For Each para In ActiveDocument.Paragraphs
        If para.Range.text = Chr(13) Then
            ' 如果是空行，创建新的幻灯片并添加之前的内容
            If content <> "" Then
                Set pptSlide = pptPres.Slides.Add(slideIndex, ppLayoutText)
                pptSlide.Shapes(1).TextFrame.textRange.text = content
                slideIndex = slideIndex + 1
                content = "" ' 重置内容
            End If
        Else
            ' 累加非空行的内容
            content = content & para.Range.text & Chr(13)
        End If
    Next para

    ' 添加最后一部分内容
    If content <> "" Then
        Set pptSlide = pptPres.Slides.Add(slideIndex, ppLayoutText)
        pptSlide.Shapes(1).TextFrame.textRange.text = content
    End If

    ' 清理
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub