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.

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 anInvalid Use of Property error.

ShapeTextFormatter.Create(wsShapes.Shape1).Clear

You will need to useCall if the you use one but not all of the optional parameters. I thinkCall 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 theTextFrame2 andLastText() 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 = TrueAttribute VB_Exposed = FalseOption ExplicitPrivate Const InvalidShapeAssingmentErrorNumber As Long = vbObjectError + 513Private Const InvalidShapeAssingmentErrorDescription As String = "Invalid Shape Assignment. Shape is a Internal Protected Property"Private Const UnderLineOutOfBoundsErrorNumber As Long = InvalidShapeAssingmentErrorNumber + 1Private 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 MsoParagraphAlignmentEnd TypePrivate m As TMembersPublic Property Get Clear() As ShapeTextFormatterAttribute Clear.VB_Description = "Note: Clear Cannot Be Use by Itself.  It Must Be Chained with Another Method"    With m.TextFrame2        If .HasText Then            .DeleteText            .TextRange.Font.Bold = msoFalse            .TextRange.ParagraphFormat.Alignment = msoAlignLeft            Call FontSize(ActiveSheet.Range("A1").Font.Size)            Call LineAlignment(msoAlignLeft)        End If    End With    Set Clear = MeEnd PropertyPublic Property Get Create(ByVal ShapeObject As Shape) As ShapeTextFormatter    With New ShapeTextFormatter        Set .SetShape(InternalAssignmentPassword) = ShapeObject        Set Create = .Self    End WithEnd PropertyPublic Property Get Self() As ShapeTextFormatter    Set Self = MeEnd PropertyPublic Property Set SetShape(ByVal Password As String, ByVal Value As Shape)    If Not Password = InternalAssignmentPassword Then        RaiseInvalidShapeAssingmentError    Else        With m            Set .Shape = Value            Set .TextFrame2 = .Shape.TextFrame2        End With    End IfEnd PropertyPublic 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 = MeEnd FunctionPublic 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 = MeEnd FunctionPrivate 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 SelectEnd SubPublic Function Bold(ByVal Value As Boolean) As ShapeTextFormatter    LastText.Font.Bold = Value    Set Bold = MeEnd FunctionPublic Function DoubleStrikeThrough(ByVal Value As MsoTriState) As ShapeTextFormatter    LastText.Font.DoubleStrikeThrough = Value    Set DoubleStrikeThrough = MeEnd FunctionPublic Function FontName(ByVal Value As String) As ShapeTextFormatter    LastText.Font.Name = Value    Set FontName = MeEnd FunctionPublic Function FontSize(ByVal Value As Single) As ShapeTextFormatter    LastText.Font.Size = Value    Set FontSize = MeEnd FunctionPublic Function ForeColor(ByVal Value As Long) As ShapeTextFormatter    LastText.Font.Fill.ForeColor.RGB = Value    Set ForeColor = MeEnd FunctionPublic Function Italic(ByVal Value As MsoTriState) As ShapeTextFormatter    LastText.Font.Italic = Value    Set Italic = MeEnd FunctionPrivate 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)    Else        Set LastText = m.TextFrame2.TextRange    End IfEnd FunctionPublic 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 = MeEnd FunctionPrivate Sub RaiseInvalidShapeAssingmentError()    Err.Raise Number:=InvalidShapeAssingmentErrorNumber, Description:=InvalidShapeAssingmentErrorDescriptionEnd SubPrivate Sub RaiseUnderLineOutOfBoundsError()    Err.Raise Number:=UnderLineOutOfBoundsErrorNumber, Description:=UnderLineOutOfBoundsDescriptionEnd SubPublic Function StrikeThrough(ByVal Value As MsoTriState) As ShapeTextFormatter    LastText.Font.StrikeThrough = Value    Set StrikeThrough = MeEnd FunctionPublic Function Underline(ByVal Value As MsoTextUnderlineType) As ShapeTextFormatter   On Error GoTo Err_Handler    LastText.Font.UnderlineStyle = Value    Set Underline = Me    Exit FunctionErr_Handler:    RaiseUnderLineOutOfBoundsErrorEnd FunctionPublic 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 = TrueAttribute VB_Exposed = TrueOption ExplicitPublic Property Get Shape1() As Shape    Set Shape1 = Me.Shapes("Shape1")End PropertyPublic Property Get ColorRange() As Range    Set ColorRange = Me.Range("A2").CurrentRegionEnd Property

Test

I intentionally switched between usingCall and not using it, for demonstration purposes.
You will need to useCall if the you use one but not all of the optional parameters. I thinkCall 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)        Next    End WithEnd SubRem Factory method used to test the ShapeTextFormatter classSub 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)        Else            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 WithEnd Sub

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

0

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.