在PowerPoint中查找并替换上标

Question

是否有一种方法可以自定义下面的代码（用于更大的下标和上标）来搜索SuperScript A，B，C…。并用数字1、2、3…在PowerPoint中代替它们。

任何帮助都将不胜感激。

代码的源。

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

Answer 1

很棒的问题！

我已经修改了要执行的代码（将大小和切换字母更改为数字）。
如果您愿意，您都可以发表评论的任何部分。毫无疑问，这样做的方法更有效（例如，将一系列的字母数量而不是一次分配给每个下标），但这几乎是在适度尺寸的文件上即可。优化它所需的时间可能会超过其保存的时间。

如果您将其他字母的字母用作子/超级订阅，则需要将它们添加到OrdinalFromletter函数中。

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