word转ppt代码需要优化

zzpsx

下列代码能把word按段落生成ppt，但是ppt中的文本溢出了，希望能改进，使得文本不溢出ppt页面。

妈妈的汤圆.7z (18.53 KB, 下载次数: 3)

2024-9-30 17:30 上传

点击文件名下载附件

Sub WordToPPT()
    Dim wordApp As word.Application
    Dim wordDoc As word.Document
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim para As word.Paragraph
    Dim slide As PowerPoint.slide
    Dim i As Long

    '获取当前的Word应用程序和文档
    Set wordApp = Application
    Set wordDoc = wordApp.ActiveDocument

    '创建新的PowerPoint应用程序和演示文稿
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add

    i = 1
    '遍历Word文档中的每个段落
    For Each para In wordDoc.Paragraphs
        '在PPT中添加新幻灯片
        Set slide = pptPres.Slides.Add(i, ppLayoutText)
        '在幻灯片的标题占位符中添加段落文本
        slide.Shapes.Title.TextFrame.textRange.text = para.Range.text
        i = i + 1
    Next para

    '释放对象
    Set para = Nothing
    Set slide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    Set wordDoc = Nothing
    Set wordApp = Nothing
End Sub

lss001

'注意：代码需要放置在Word的ThisDocument中
Sub Document_Open() '设置WordToppt3宏快捷键：F5
     Application.KeyBindings.Add 2, "WordToppt3", vbKeyF5
End Sub

Sub WordToppt3()
    Dim ppt As Object, pre As Object
    Dim par As Paragraph, w!, h!, k%
   
    '引用ppt应用/App
    Set ppt = CreateObject("Powerpoint.Application")
    Set pre = ppt.Presentations.Add '创建ppt幻灯片
    w = pre.PageSetup.SlideWidth 'ppt幻灯片宽高
    h = pre.PageSetup.SlideHeight
   
    k = 1 '初始化k*****
    With Application.ActiveDocument 'Word对象
    For Each par In .Paragraphs 'Wrod段落
        With pre.Slides.Add(k, 12)  'ppt空白页
        With .Shapes.AddTextbox(1, 0, 0, w, h) 'ppt对象
            With .TextFrame.TextRange 'ppt属性
                .Font.Size = 24 '字体不要太大
                .Text = par.Range.Text 'ppt文本
                k = k + 1
            End With
        End With
        End With
    Next
    t = Timer '延时/保存ppt
    While Timer < t + 2: DoEvents: Wend
    pre.SaveAs .Path & "\Words3.pptx"
    End With
   
    pre.Close '关闭/退出ppt
    ppt.Quit
    Set ppt = Nothing '释放对象
    Set pre = Nothing
End Sub