The preeminence is to have every method of the formatter return the formatter as a reference. This allows it to add and format text in chain. Such as:

ShapeTextFormatter.Create(Shape).AddText("Hello ").FontSize(16).Bold(True).AddText("Cruel ").StrikeThrough(msoCTrue).FontSize(6) _
.AddText("World!").FontSize(16).Bold(True).StrikeThrough (msoFalse)

Note: Formats are applied to the last text block.

Hello Cruel World Image

Overall, I think that it turned out okay. But I did have a few sticky points.

In a couple of cases, I had to convert range enum values to their shape counterparts. UnderLineFromRange() had a couple of its values double up. I'm not sure if there is a distinction between them or not.

The class has 20 methods and only 2 error handlers. Did I miss any?

White-Space, what white-space! Everything is so packed in. It seems like it need more white-space but where to put it? I couldn't think of a spacing pattern that made since.

Using .Clear() by itself throws an Invalid Use of Property error.


You will need to use Call if the you use one but not all of the optional parameters. I think Call could be omitted if named parameters are used. I should probably add a big ugly banner warning to the class.

ToDo List

There are always more features that be added. It would be nice to be able to fade text using the Transparency. There are too many text effects to implement. Returning an instance of the the TextFrame2 and LastText() would probably make since. I avoided it because I didn't want to break away from the Builder Pattern.

Of course naming could almost always be improved.

ShapeTextFormatter: Class

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const InvalidShapeAssingmentErrorNumber As Long = vbObjectError + 513
Private Const InvalidShapeAssingmentErrorDescription As String = "Invalid Shape Assignment. Shape is a Internal Protected Property"
Private Const UnderLineOutOfBoundsErrorNumber As Long = InvalidShapeAssingmentErrorNumber + 1
Private Const UnderLineOutOfBoundsDescription As String = "IUnderLine Value is Out of Bounds. Hint: Use UnderLineFromRange for Ranges"

Private Const InternalAssignmentPassword = "AllowAssignment"

Private Type TMembers
    LastTextStart  As Long
    ParagraphFormat As ParagraphFormat2
    Shape As Shape
    TextFrame2 As TextFrame2
    LineAlignment As MsoParagraphAlignment
End Type

Private m As TMembers

Public Property Get Clear() As ShapeTextFormatter
Attribute Clear.VB_Description = "Note: Clear Cannot Be Use by Itself.  It Must Be Chained with Another Method"
    With m.TextFrame2
        If .HasText Then
            .TextRange.Font.Bold = msoFalse
            .TextRange.ParagraphFormat.Alignment = msoAlignLeft
            Call FontSize(ActiveSheet.Range("A1").Font.Size)
            Call LineAlignment(msoAlignLeft)
        End If
    End With
    Set Clear = Me
End Property

Public Property Get Create(ByVal ShapeObject As Shape) As ShapeTextFormatter
    With New ShapeTextFormatter
        Set .SetShape(InternalAssignmentPassword) = ShapeObject
        Set Create = .Self
    End With
End Property

Public Property Get Self() As ShapeTextFormatter
    Set Self = Me
End Property

Public Property Set SetShape(ByVal Password As String, ByVal Value As Shape)
    If Not Password = InternalAssignmentPassword Then
        With m
            Set .Shape = Value
            Set .TextFrame2 = .Shape.TextFrame2
        End With
    End If
End Property

Public Function AddText(ByVal Text As String, Optional isBold As Boolean, _
    Optional Caps As MsoTextCaps = -1, Optional TextAlignment As _
    MsoParagraphAlignment = -1) As ShapeTextFormatter
    Call ApplyCaps(Text, Caps)
    If Len(Text) > 0 Then
        m.LastTextStart = m.TextFrame2.TextRange.length
        Call m.TextFrame2.TextRange.InsertAfter(Text)
    End If
    If isBold Then Call Bold(isBold)
    Set AddText = Me
End Function

Public Function AppendText(ByVal Text As String, Optional isBold As Boolean, _
    Optional Caps As MsoTextCaps = -1, Optional TextAlignment As _
    MsoParagraphAlignment = -1) As ShapeTextFormatter
    Call m.TextFrame2.TextRange.InsertAfter(vbNewLine)
    Call AddText(Text, isBold, Caps, TextAlignment)
    Set AppendText = Me
End Function

Private Sub ApplyCaps(ByRef Text As String, ByRef Caps As MsoTextCaps)
    Select Case Caps
        Case MsoTextCaps.msoCapsMixed
            Text = StrConv(Text, vbProperCase)
        Case MsoTextCaps.msoNoCaps
            Text = StrConv(Text, vbLowerCase)
        Case MsoTextCaps.msoSmallCaps
            Text = StrConv(Text, vbUpperCase)
        Case MsoTextCaps.msoAllCaps
            Text = StrConv(Text, vbUpperCase)
    End Select
End Sub

Public Function Bold(ByVal Value As Boolean) As ShapeTextFormatter
    LastText.Font.Bold = Value
    Set Bold = Me
End Function

Public Function DoubleStrikeThrough(ByVal Value As MsoTriState) As ShapeTextFormatter
    LastText.Font.DoubleStrikeThrough = Value
    Set DoubleStrikeThrough = Me
End Function

Public Function FontName(ByVal Value As String) As ShapeTextFormatter
    LastText.Font.Name = Value
    Set FontName = Me
End Function

Public Function FontSize(ByVal Value As Single) As ShapeTextFormatter
    LastText.Font.Size = Value
    Set FontSize = Me
End Function

Public Function ForeColor(ByVal Value As Long) As ShapeTextFormatter
    LastText.Font.Fill.ForeColor.RGB = Value
    Set ForeColor = Me
End Function

Public Function Italic(ByVal Value As MsoTriState) As ShapeTextFormatter
    LastText.Font.Italic = Value
    Set Italic = Me
End Function

Private Function LastText() As TextRange2
    If m.TextFrame2.HasText Then
        Dim length As Long
        length = m.TextFrame2.TextRange.length - m.LastTextStart
        Set LastText = m.TextFrame2.TextRange.Characters(m.LastTextStart + 1, length)
        Set LastText = m.TextFrame2.TextRange
    End If
End Function

Public Function LineAlignment(ByVal Value As MsoParagraphAlignment) As ShapeTextFormatter

    Value = Switch(Value = xlLeft, MsoParagraphAlignment.msoAlignLeft, _
                                Value = xlCenter, MsoParagraphAlignment.msoAlignCenter, _
                                Value = xlRight, MsoParagraphAlignment.msoAlignRight, _
                                True, Value)

    m.LineAlignment = Value
    If m.TextFrame2.HasText Then LastText.ParagraphFormat.Alignment = Value

    Set LineAlignment = Me
End Function

Private Sub RaiseInvalidShapeAssingmentError()
    Err.Raise Number:=InvalidShapeAssingmentErrorNumber, Description:=InvalidShapeAssingmentErrorDescription
End Sub

Private Sub RaiseUnderLineOutOfBoundsError()
    Err.Raise Number:=UnderLineOutOfBoundsErrorNumber, Description:=UnderLineOutOfBoundsDescription
End Sub

Public Function StrikeThrough(ByVal Value As MsoTriState) As ShapeTextFormatter
    LastText.Font.StrikeThrough = Value
    Set StrikeThrough = Me
End Function

Public Function Underline(ByVal Value As MsoTextUnderlineType) As ShapeTextFormatter
   On Error GoTo Err_Handler
    LastText.Font.UnderlineStyle = Value
    Set Underline = Me
    Exit Function
End Function

Public Function UnderLineFromRange(ByVal Value As XlUnderlineStyle) As ShapeTextFormatter
   Select Case Value
       Case XlUnderlineStyle.xlUnderlineStyleDouble, XlUnderlineStyle.xlUnderlineStyleDoubleAccounting
           Value = MsoTextUnderlineType.msoUnderlineDoubleLine
       Case XlUnderlineStyle.xlUnderlineStyleNone
            Value = MsoTextUnderlineType.msoNoUnderline
       Case XlUnderlineStyle.xlUnderlineStyleSingle, XlUnderlineStyle.xlUnderlineStyleSingleAccounting
            Value = MsoTextUnderlineType.msoUnderlineSingleLine
   End Select
    Set UnderLineFromRange = Underline(Value)
End Function

wsShapes: Worksheet

Attribute VB_Name = "wsShapes"
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Public Property Get Shape1() As Shape
    Set Shape1 = Me.Shapes("Shape1")
End Property

Public Property Get ColorRange() As Range
    Set ColorRange = Me.Range("A2").CurrentRegion
End Property


I intentionally switched between using Call and not using it, for demonstration purposes.
You will need to use Call if the you use one but not all of the optional parameters. I think Call could be omitted if named parameters are used.

Sub Test()
    Dim ColorRange  As Range
    Set ColorRange = wsShapes.ColorRange
    With ShapeTextFormatter.Create(wsShapes.Shape1).Clear
        Dim r As Long

        AddTextWithFormatsFromCell .Self, ColorRange.Cells(1)
        For r = 2 To ColorRange.Rows.Count
            AddTextWithFormatsFromCell .Self, ColorRange.Cells(r, 1), True
            Call .AddText(vbTab).Underline(msoNoUnderline)
            Call .StrikeThrough(msoFalse)
            AddTextWithFormatsFromCell .Self, ColorRange.Cells(r, 2)
    End With
End Sub

Rem Factory method used to test the ShapeTextFormatter class
Sub AddTextWithFormatsFromCell(ByVal Formatter As ShapeTextFormatter, ByRef Cell As Range, Optional ByVal AppendNewLine As Boolean)
    With Formatter.Create(wsShapes.Shape1)
        If AppendNewLine Then
            Call .AppendText(Cell.Text)
            Call .AddText(Cell.Text)
        End If
        Call .Bold(Cell.Font.Bold)
        Call .Italic(Cell.Font.Italic)
        .FontName Cell.Font.Name
        .FontSize Cell.Font.Size
        .ForeColor Cell.Font.Color
        .LineAlignment Cell.HorizontalAlignment
        .StrikeThrough Cell.Font.StrikeThrough
        .UnderLineFromRange Cell.Font.Underline
    End With
End Sub

Demo Output Image

If you made it this far you deserve an Upvote! I do tend to ramble on.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.