Loop - Insert powerpoint title with VBA for 10 slides-CodePudding

I saw some code in stackoverflow that inserts a title in one slide. I would like to add the same slide title for a given number of slides, for example, for the first ten slides. I understand it can be done with a loop or with another (maybe better) way: selecting the range of the slides of interests

Could someone help me?

Sub add_title()

Dim shpCurrShape As Shape

Dim ppPres As Presentation

Set ppPres = ActivePresentation

With ActivePresentation.Slides.Range(Array(1, 2, 3, 4, 5))

If Not .Shapes.HasTitle Then
    Set shpCurrShape = .Shapes.AddTitle
Else
    Set shpCurrShape = .Shapes.Title
End If

    With shpCurrShape
    With .TextFrame.TextRange
        '~~> Set text here
        .Text = "BLAH BLAH"
        '~~> Alignment
        .ParagraphFormat.Alignment = 1
       '~~> Working with font
       With .Font
          .Bold = msoTrue
          .Name = "Tw Cen MT"
          .Size = 24
          .Color = RGB(0, 0, 0)
       End With
    End With
End With
End With
End Sub

Also, how would I define the array for indicating slides 20 to 30?

Thank you in advance,

CodePudding user response：

I would move the decision over which slides to change to a different sub, then call add_title only to those slides you wish to change.

Sub AddTitles()
    Dim i As Long
    For i = 20 to 30
        add_title i
    Next i
End Sub

Sub add_title(ByVal slideNumber As Long)
    Dim ppPres As Presentation
    Set ppPres = ActivePresentation

    With ppPres.Slides(slideNumber)
        Dim shpCurrShape As Shape
        If Not .Shapes.HasTitle Then
            Set shpCurrShape = .Shapes.AddTitle
        Else
            Set shpCurrShape = .Shapes.Title
        End If

        With shpCurrShape
            With .TextFrame.TextRange
                '~~> Set text here
                .Text = "BLAH BLAH"
                '~~> Alignment
                .ParagraphFormat.Alignment = 1
               '~~> Working with font
               With .Font
                  .Bold = msoTrue
                  .Name = "Tw Cen MT"
                  .Size = 24
                  .Color = RGB(0, 0, 0)
               End With
            End With
        End With
    End With
End Sub