如何将PPT中的自动编号变成手动编号？

哈哈哈尔

1. 
   

复制代码

1. Sub ConvertAutoToManualNumbering()
   
2.     Dim slide As slide
   
3.     Dim shape As shape
   
4.     Dim paragraph As ParagraphFormat
   
5.     Dim paragraphText As String
   
6.     Dim slideIndex As Integer
   
7.     Dim shapeIndex As Integer
   
8.     Dim paragraphIndex As Integer
   
9.     Dim bulletNumber As Integer
   
10. 
    
11.     ' 遍历每张幻灯片
    
12.     For slideIndex = 1 To ActivePresentation.Slides.Count
    
13.         Set slide = ActivePresentation.Slides(slideIndex)
    
14.         
    
15.         ' 遍历每个形状
    
16.         For shapeIndex = 1 To slide.Shapes.Count
    
17.             Set shape = slide.Shapes(shapeIndex)
    
18.             
    
19.             ' 检查形状是否是文本框
    
20.             If shape.HasTextFrame Then
    
21.                 If shape.TextFrame.HasText Then
    
22.                     ' 重置编号
    
23.                     bulletNumber = 1
    
24.                     
    
25.                     ' 遍历每段文字
    
26.                     For paragraphIndex = 1 To shape.TextFrame.TextRange.Paragraphs.Count
    
27.                         With shape.TextFrame.TextRange.Paragraphs(paragraphIndex)
    
28.                             ' 判断是否有自动编号
    
29.                             If .ParagraphFormat.Bullet.Type = ppBulletNumbered Then
    
30.                                 ' 获取段落文本并添加手动编号
    
31.                                 paragraphText = bulletNumber & ". " & .Text
    
32.                                 .Text = paragraphText
    
33.                                 
    
34.                                 ' 取消自动编号
    
35.                                 .ParagraphFormat.Bullet.Type = ppBulletNone
    
36.                                 
    
37.                                 ' 增加手动编号
    
38.                                 bulletNumber = bulletNumber + 1
    
39.                             End If
    
40.                         End With
    
41.                     Next paragraphIndex
    
42.                 End If
    
43.             End If
    
44.         Next shapeIndex
    
45.     Next slideIndex
    
46. End Sub
    
47. 
    

复制代码

处理后的文本编号和之前的样式不能对应上，而且没有处理干净，请教一下大神这是什么原因？

处理前：

处理前

处理后：

lss001

Sub pptbullet()
    Dim sld As Slide, shp As Shape
    Dim pRng As TextRange: k& = 1
   
    With Application.ActivePresentation
    For Each sld In .Slides
        For Each shp In sld.Shapes
        If shp.Type = msoTextBox Then
            Set pRng = shp.TextFrame.TextRange
            For Each par In pRng.Paragraphs
            With par.ParagraphFormat.Bullet
                If .Type <> 0 Then
                    .Type = 0
                    p = Replace(par.Text, Chr(13), "")
                    par.Text = k & "." & p
                    k = k + 1
                End If
            End With
            Next
        End If
        Next
    Next
    End With
End Sub

哈哈哈尔

lss001 发表于 2024-10-16 12:10
Sub pptbullet()
    Dim sld As Slide, shp As Shape
    Dim pRng As TextRange: k& = 1

感谢回复，但这个代码运行后编号的样式和内容变了

原始ppt内容：



调整后：



我看了些其它资料貌似要判断之前编号的样式来分析字符编码然后重构一个？

lss001

楼上代码仅供参考

哈哈哈尔

lss001 发表于 2024-10-18 14:43
您没有提供附件，
楼上代码仅供参考
如有需要应根据实际调整

好，谢谢，我再看看