How to change font of a substring in powerpoint?

Question

I want to change every digit in my powerpoint presentation to Times New Roman. I have found the code to change the font of whole textbox but I want to change the font of only the numbers.

I have a PowerPoint Macro VBScript:

Sub use_regex()
    Dim regX As Object
    Dim osld As Slide
    Dim oshp As Shape
    Dim strInput As String
    Dim b_found As Boolean
    Dim iRow As Integer
    Dim iCol As Integer

    Set regX = CreateObject("vbscript.regexp")
    With regX
        .Global = True
        .Pattern = "(\d)"
    End With
    For Each osld In ActivePresentation.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTable Then
                For iRow = 1 To oshp.Table.Rows.Count
                    For iCol = 1 To oshp.Table.Columns.Count
                        strInput = oshp.Table.Cell(iRow, iCol).Shape.TextFrame.TextRange.Text
                        b_found = regX.Test(strInput)
                        If b_found = True Then
                            strInput = regX.Replace(strInput, "$1")
                            oshp.Table.Cell(iRow, iCol).Shape.TextFrame.TextRange = strInput
                        End If
                    Next iCol
                Next iRow
            Else
                If oshp.HasTextFrame Then
                    If oshp.TextFrame.HasText Then
                        strInput = oshp.TextFrame.TextRange.Text
                        b_found = regX.Test(strInput)
                        If b_found = True Then
                            strInput = regX.Replace(strInput, "$1")
                            oshp.TextFrame.TextRange = strInput
                        End If
                    End If
                End If
            End If
        Next oshp
    Next osld
    Set regX = Nothing
End Sub

Source:http://www.pptalchemy.co.uk/PowerPoint_RegEx.html

This is able to identify each digit but how to change its font?

Answer 1

I finally did this. Here's the code:

Sub use_regex()
    Dim regX As Object
    Dim osld As Slide
    Dim oshp As Shape
    Dim strInput As String
    Dim b_found As Boolean
    Dim iRow As Integer
    Dim iCol As Integer

    Set regX = CreateObject("vbscript.regexp")
    With regX
        .Global = True
        .Pattern = "(\d)"
    End With
    For Each osld In ActivePresentation.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTable Then
                For iRow = 1 To oshp.Table.Rows.Count
                    For iCol = 1 To oshp.Table.Columns.Count
                        strInput = oshp.Table.Cell(iRow, iCol).Shape.TextFrame.TextRange.Text
                        b_found = regX.Test(strInput)
                        If b_found = True Then

                             Set myMatches = regX.Execute(strInput)
                             For Each myMatch In myMatches
                            oshp.Table.Cell(iRow, iCol).Shape.TextFrame.TextRange.Characters(myMatch.FirstIndex + 1, myMatch.Length).Characters.Font.Name = "Times New Roman"
                            Next
                        End If
                    Next iCol
                Next iRow
            Else
                If oshp.HasTextFrame Then
                    If oshp.TextFrame.HasText Then
                        strInput = oshp.TextFrame.TextRange.Text
                        b_found = regX.Test(strInput)
                        If b_found = True Then

                            Set myMatches = regX.Execute(strInput)
                                For Each myMatch In myMatches
                                    oshp.TextFrame.TextRange.Characters(myMatch.FirstIndex + 1, myMatch.Length).Characters.Font.Name = "Times New Roman"
                                Next

                        End If
                    End If
                End If
            End If
        Next oshp
    Next osld
    Set regX = Nothing
End Sub