スライドの右上に番号を振る

Sub SlideCount()

'MsgBox (ActivePresentation.Slides.Count)

Dim pp As Presentation

Dim shp As Shape

Dim sd As Slide

Dim cm As Double, xx As Double, yy As Double, rr As Double

Dim i As Long, n As Long

Dim aa As Double

Set pp = ActivePresentation

n = pp.Slides.Count

cm = 72 / 2.54

xx = 31.87 * cm

yy = 0

rr = 2 * cm

aa = 4

xx = 31.87 + 2 - aa

xx = xx * cm

rr = aa * cm

For i = 1 To n

Set sd = pp.Slides(i)

Set shp = sd.Shapes.AddShape(msoShapeOval, xx, yy, rr, rr / 2)

shp.TextFrame2.TextRange.Characters = "46-" + Format(i + 5, "0")

With shp.TextFrame2.TextRange.Font

.NameComplexScript = "Times New Roman"

.NameFarEast = "Times New Roman"

.Name = "Times New Roman"

End With

With shp.Fill

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorBackground1

.ForeColor.TintAndShade = 0

.ForeColor.Brightness = -0.15

.Transparency = 0

.Solid

End With

With shp.Line

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorBackground1

.ForeColor.TintAndShade = 0

.ForeColor.Brightness = -0.5

.Transparency = 0

End With

With shp.TextFrame2.TextRange.Font.Fill

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorText1

.ForeColor.TintAndShade = 0

.ForeColor.Brightness = 0

.Transparency = 0

.Solid

End With

With shp.TextFrame2.TextRange.Characters.ParagraphFormat

' .FirstLineIndent = 0

' .Alignment = msoAlignLeft

End With

With shp.TextFrame2

.VerticalAnchor = msoAnchorMiddle

.TextRange.ParagraphFormat.Alignment = msoAlignCenter

End With

Next i

End Sub