|
发表于 2024-9-30 19:54
来自手机
|
显示全部楼层
'注意:代码需要放置在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 |
|