Find and replace superscripts in PowerPoint

Viewed 92

Is there a way to customize the code below (for making subscripts and superscripts larger) to search for superscript a , b, c …. and replace them with numbers 1, 2, 3 …in PowerPoint.

Any help would be much appreciated.

Source for the code.

Sub BumpTheSubsAndSupers()

Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double

dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
  ' Check each shape on the slide
  For Each oSh In oSl.Shapes
    ' Make sure it's got text
    If oSh.HasTextFrame Then
      If oSh.TextFrame.HasText Then
        With oSh.TextFrame.TextRange
          For x = 1 To .Runs.Count
            If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
            ' it's a sub/super; make it four points
            ' bigger than the text immediately prior:
            .Runs(x).Characters.Font.Size = _
               .Runs(x - 1).Characters.Font.Size + dBumpBy
        End If  ' it's a sub/superscript
      Next x
    End With    ' textframe.textrange
      End If    '  .HasText
    End If  '  .HasTextFrame
  Next oSh      '
Next oSl

End Sub
1 Answers

Great question!

I've modified the code to do both (change the size and switch letters to numbers). You can comment out whichever part you don't want if you like. There are doubtless more efficient ways of doing this (like splitting the array of letters once rather than once for each subscript) but it's all but instant on moderately sized files; the time it'd take to optimize it would probably exceed the time it'd save in use.

If you use letters from other alphabets as sub/superscripts, you'll want to add them to the OrdinalFromLetter function.

Option Explicit

Sub BumpTheSubsAndSupers()

Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double

dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
  ' Check each shape on the slide
  For Each oSh In oSl.Shapes
    ' Make sure it's got text
    If oSh.HasTextFrame Then
      If oSh.TextFrame.HasText Then
        With oSh.TextFrame.TextRange
          For x = 1 To .Runs.Count
            If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
            ' it's a sub/super; make it four points
            ' bigger than the text immediately prior:
            .Runs(x).Characters.Font.Size = _
               .Runs(x - 1).Characters.Font.Size + dBumpBy
            .Runs(x).Text = CStr(OrdinalFromLetter(.Runs(x)))
        End If  ' it's a sub/superscript
      Next x
    End With    ' textframe.textrange
      End If    '  .HasText
    End If  '  .HasTextFrame
  Next oSh      '
Next oSl

End Sub

Function OrdinalFromLetter(sLetter As String) As Long
Dim x As Long
Dim aLetters As Variant
aLetters = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",")
For x = LBound(aLetters) To UBound(aLetters)
    If UCase(sLetter) = aLetters(x) Then
        OrdinalFromLetter = x
        Exit Function
    End If
Next   
End Function
Related