|
楼主 |
发表于 2024-9-21 18:26
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
谢谢高手,完整的代码如下,太厉害了
Sub wordtoppt()
Rem 2024年9月20日亲测可用
Dim wDoc As Document, wText$, arr$()
Dim ppt As Object, pre As Object
Dim sld As Object, x%, y%, i%, j%, s$, k%
Set wDoc = ActiveDocument
wText = wDoc.ActiveWindow.Selection.text
If VBA.Len(wText) <= 1 Then MsgBox "请选择文本!": Exit Sub
arr = Split(wText, VBA.Chr(13))
y = UBound(arr) Mod 7
If y Then k = 1 Else k = 0
x = UBound(arr) \ 7 + k
Set ppt = CreateObject("PowerPoint.Application")
'ppt.Activate
Set pre = ppt.Presentations.Add
For i = x To 1 Step -1
Set sld = pre.Slides.Add(1, 12)
With sld.Shapes.AddTextbox(1, 120, 60, 900, 360)
If i < x Or y = 0 Then k = 7 Else k = y
s = ""
For j = (i - 1) * 7 + 1 To (i - 1) * 7 + k
s = s & j & ". " & Replace(arr(j - 1), Chr(13), "") & VBA.vbNewLine
Next
.TextFrame.TextRange.text = s
.TextFrame.TextRange.Font.Size = 48
.TextFrame.TextRange.Font.Bold = True ' 添加这一行代码以设置字体为加粗
End With
Next
Dim t As Date: t = VBA.Timer '延时
While VBA.Timer < t + 1: VBA.DoEvents: Wend
pre.SaveAs wDoc.Path & "\words.pptx" '保存
Set sld = Nothing
Set pre = Nothing
Set ppt = Nothing
Set wDoc = Nothing
End Sub
|
|