哪位高手能用vba代码给ppt加页码？

zzpsx

ppt中用母版视图加页码的方法太麻烦，步骤太多。
哪位高手能用vba代码给ppt加页码？
如何用vba给ppt右下角加红色页码，页码字号54.rar (824.79 KB, 下载次数: 6)

2021-6-28 21:36 上传

点击文件名下载附件

网上看到一个用vba给ppt加页码进度条的，可惜不是页码。
Sub AddProgressBar()
    On Error Resume Next
        With ActivePresentation
              For X = 2 To .Slides.Count - 1 '第一页和最后一页不加
              .Slides(X).Shapes("PB").Delete
              Set s = .Slides(X).Shapes.AddShape(msoShapeRectangle, _
              0, .PageSetup.SlideHeight - 6, _
              X * .PageSetup.SlideWidth / .Slides.Count, 5) '条高度
              s.Fill.ForeColor.RGB = RGB(246, 202, 5) '设置颜色
              s.Name = "PB"
              Next X:
        End With
End Sub
————————————————
版权声明：本文为CSDN博主「fandroid」的原创文章，遵循CC 4.0 BY-SA版权协议，转载请附上原文出处链接及本声明。
原文链接：https://blog.csdn.net/fandroid/article/details/45970243

shenjianrong163

1. Sub AddPageShape()
   
2.     Dim Width As Single, Height As Single, shp As Shape, n As Long, i As Long
   
3.     With ActivePresentation
   
4.         Width = .PageSetup.SlideWidth '幻灯片的宽度
   
5.         Height = .PageSetup.SlideHeight '幻灯片的高度
   
6.         n = .Slides.Count  '计算幻灯片的总数
   
7.         On Error GoTo 0
   
8.         For i = 1 To n '从第1页开始添加
   
9.         On Error Resume Next
   
10.         .Slides(i).Shapes("PageShape").Delete
    
11.         Set shp = .Slides(i).Shapes.AddTextbox(msoTextOrientationHorizontal, Width - 150, Height - 70, 30, 48)    '水平文本框，左边距，顶边距，高度，宽度
    
12.         With shp
    
13.             .Name = "PageShape"
    
14.             .TextFrame.WordWrap = msoFalse
    
15.             .TextFrame.TextRange.Text = "第" & i & "页"  '页码
    
16.             .TextFrame.TextRange.Font.NameAscii = "黑体"
    
17.             .TextFrame.TextRange.Font.NameFarEast = "黑体"
    
18.             .TextFrame.TextRange.Font.Size = 54   '字号
    
19.             .TextFrame.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
    
20.         End With
    
21.         Next
    
22.     End With
    
23. End Sub

复制代码

zzpsx

谢谢楼上的高手的神奇代码，效果非常好。
假如一个ppt有8个页面，运行以上代码后，插入了八个页码，但是我又插入了一个ppt页面，此时不能自动增加页码，可否修改代码，使其能按照页数增加或删除自动更新页码，谢谢。 更新ppt页码需求.rar (1.55 MB, 下载次数: 22)

2021-12-4 13:57 上传

点击文件名下载附件

shenjianrong163

zzpsx 发表于 2021-12-4 13:37
谢谢楼上的高手的神奇代码，效果非常好。
假如一个ppt有8个页面，运行以上代码后，插入了八个页码，但是我 ...

一、插入类模块，命名为“clsEvent”，在类模块中添加如下代码

1. Public WithEvents pptApp As Application
   
2. Private Sub pptApp_SlideSelectionChanged(ByVal SldRange As SlideRange)
   
3.     Call AddPage
   
4. End Sub

复制代码

二、插入模块，添加如下代码

1. Dim X As New clsEvent
   
2. Sub AddPage()
   
3.     Set X.pptApp = Application
   
4.     Dim Width As Single, Height As Single, shp As Shape, n As Long, i As Long
   
5.     With ActivePresentation
   
6.         Width = .PageSetup.SlideWidth '幻灯片的宽度
   
7.         Height = .PageSetup.SlideHeight '幻灯片的高度
   
8.         n = .Slides.Count  '计算幻灯片的总数
   
9.         On Error GoTo 0
   
10.         For i = 1 To n '从第1页开始添加
    
11.         On Error Resume Next
    
12.         .Slides(i).Shapes("PageShape").Delete
    
13.         Set shp = .Slides(i).Shapes.AddTextbox(msoTextOrientationHorizontal, Width - 150, Height - 70, 30, 48)    '水平文本框，左边距，顶边距，高度，宽度
    
14.         With shp
    
15.             .Name = "PageShape"
    
16.             .TextFrame.WordWrap = msoFalse
    
17.             .TextFrame.TextRange.Text = "第" & i & "页"  '页码
    
18.             .TextFrame.TextRange.Font.NameAscii = "黑体"
    
19.             .TextFrame.TextRange.Font.NameFarEast = "黑体"
    
20.             .TextFrame.TextRange.Font.Size = 54   '字号
    
21.             .TextFrame.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
    
22.         End With
    
23.         Next
    
24.     End With
    
25. End Sub

复制代码

三、每次打开PPT都先运行一遍“AddPage”

前进者

标记一下，以便后期学习！

zzpsx

shenjianrong163 发表于 2021-12-11 10:46
一、插入类模块，命名为“clsEvent”，在类模块中添加如下代码
二、插入模块，添加如下代码
三、每次打 ...

谢谢，页码格式可否改为第几页，共几页？

shenjianrong163

zzpsx 发表于 2023-2-23 13:42
谢谢，页码格式可否改为第几页，共几页？

.TextFrame.TextRange.Text = "第" & i & "页，共"  &  n  & "页"        '页码