word选中文字如何变成ppt？

zzpsx

好像还是有自动换行
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, 360, 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
       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

lss001

zzpsx 发表于 2024-9-21 15:52
好像还是有自动换行
Sub wordtoppt()
Rem 2024年9月20日亲测可用

测试了一下ppt文本框宽度不够
把宽度→360更改为→900即可↓

With sld.Shapes.AddTextbox(1, 120, 60, 900, 360)

zzpsx

谢谢高手，完整的代码如下，太厉害了
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