superscript letters in vba string variable

Question

I am looking for how to super/subscript a letter/digit in a VBA string variable. I am working in excel with charts that have axes, titles and chart titles that require s-scripting. Additionally, there is a formula to go in a textbox: Cpt = Cp0 * e^(-ket) where all the p's, t's and 0 are subscripts. The entire expression, (-ket) is superscripted with embedded subscripting for the e (the e between the k & t). Finally, all the specially formatted string variables will be copied to PowerPoint variables via clipboard/gettext.

Any help / guidance is greatly appreciated.

Pat K.

Answer 1

It is workaround Idea only and the code may not be useful for your purpose depending on source and destination of the data and may be treated as demo only. i have only used excel cells and Text Boxes on a sheet as destination and used PowerPoint Text Boxes as target.

The simple approach is that while picking up String from formatted cells/Text Boxes from excel to a variable, Font Subscript, Superscript information is also to be picked up in a parallel variable (here in a 2D Array). The same font information may be used while writing in PowerPoint. The demo idea have to be Modified/Converted to suit your need.

Demo Screen shot

The demo code

Sub Sscript()
Dim CellStr() As Variant
Dim Rng As Range, Cell As Range
Dim shp As Shape
Dim VarNo As Long, i As Long, j As Long, Txt As String, FntInfo As String


Set Rng = Range("C3:C7")    'Range used for collecting input data and font information for the variable
VarNo = 0
    'loop used for Trial may be directly assigned to CellStr by increasing Varno by one for each cell
    For Each Cell In Rng.Cells
    VarNo = VarNo + 1
    ReDim Preserve CellStr(1 To 2, 1 To VarNo)
    Txt = Cell.Value
    CellStr(1, VarNo) = Txt
    FntInfo = ""
        For i = 1 To Len(Txt)
        If Cell.Characters(i, 1).Font.Subscript = True Then
        FntInfo = FntInfo & "A"
        ElseIf Cell.Characters(i, 1).Font.Superscript = True Then
        FntInfo = FntInfo & "B"
        Else
        FntInfo = FntInfo & "C"
        End If
        Next i
    CellStr(2, VarNo) = FntInfo
    Next Cell

    'again loop used for Trial may be directly assigned to CellStr from Textboxes in the sheet
    For Each shp In ActiveSheet.Shapes
    If shp.Type = msoTextBox Then
    VarNo = VarNo + 1
    ReDim Preserve CellStr(1 To 2, 1 To VarNo)
    Txt = shp.TextFrame2.TextRange.Text
    CellStr(1, VarNo) = Txt
    FntInfo = ""
        For i = 1 To Len(Txt)
        If shp.TextFrame2.TextRange.Characters(i, 1).Font.Subscript = msoTrue Then
        FntInfo = FntInfo & "A"
        ElseIf shp.TextFrame2.TextRange.Characters(i, 1).Font.Superscript = msoTrue Then
        FntInfo = FntInfo & "B"
        Else
        FntInfo = FntInfo & "C"
        End If
        Next i
    CellStr(2, VarNo) = FntInfo
    End If
    Next

'Start of Trial code in excel to be deleted
For i = 1 To UBound(CellStr, 2)
ActiveSheet.Cells(i, 10).Value = CellStr(1, i)
ActiveSheet.Cells(i, 11).Value = CellStr(2, i)
FntInfo = CellStr(2, i)
    For j = 1 To Len(FntInfo)
    ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = False
    ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = False
    If Mid(FntInfo, j, 1) = "A" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = True
    If Mid(FntInfo, j, 1) = "B" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = True
    Next j
Next
'End of Trial code in excel to be deleted


'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld  As Slide
Dim Pshp  As Shape

Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)

    For i = 1 To UBound(CellStr, 2)
    Set Pshp = Sld.Shapes(i)
    Pshp.TextFrame.TextRange.Text = CellStr(1, i)
    FntInfo = CellStr(2, i)
        For j = 1 To Len(FntInfo)
        Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = False
        Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = False
        If Mid(FntInfo, j, 1) = "A" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = True
        If Mid(FntInfo, j, 1) = "B" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = True
        Next j
    Next

End Sub

It is suggested to Add reference of Microsoft PowerPoint Object Library and thanks for asking a good question/challenge to achieve something seemingly not possible but logically possible.

Edit: another more simplistic approach (the 1st half of the String variable contains actual string and 2nd half of the variable contains Font Info) with generalized functions is also added below

Sub Sscript2()
Dim Txt As String, Var1 As String, Var2 As String
Dim Addr As String

Var1 = GetVarFont("C6")  ' 1st half of the var contains actual string and 2nd half contain font Info
Var2 = GetVarFont("C7")  ' 1st half of the var contains actual string and 2nd half contain font Info

'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld  As Slide
Dim Pshp  As Object

Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)

WriteShp Sld.Shapes(8).TextFrame.TextRange, Var1
WriteShp Sld.Shapes(9).TextFrame.TextRange, Var2
End Sub

Sub WriteShp(Ptxt As TextRange, VarX As String)
Dim i As Long
Ptxt.Text = Left(VarX, Len(VarX) / 2)
    For i = 1 To Len(VarX) / 2
    Ptxt.Characters(i, 1).Font.Subscript = False
    Ptxt.Characters(i, 1).Font.Superscript = False
    If Mid(VarX, Len(VarX) / 2 + i, 1) = "A" Then Ptxt.Characters(i, 1).Font.Subscript = True
    If Mid(VarX, Len(VarX) / 2 + i, 1) = "B" Then Ptxt.Characters(i, 1).Font.Superscript = True
    Next
End Sub

Function GetVarFont(Addr As String) As String
Dim Txt As String, i As Long
Txt = Range(Addr).Value
GetVarFont = Txt
        For i = 1 To Len(Txt)
        If Range(Addr).Characters(i, 1).Font.Subscript = True Then
        GetVarFont = GetVarFont & "A"
        ElseIf Range(Addr).Characters(i, 1).Font.Superscript = True Then
        GetVarFont = GetVarFont & "B"
        Else
        GetVarFont = GetVarFont & "C"
        End If
        Next i
End Function