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 an Invalid Use of Property error.
ShapeTextFormatter.Create(wsShapes.Shape1).Clear
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
.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 = 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
RaiseInvalidShapeAssingmentError
Else
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)
Else
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
Err_Handler:
RaiseUnderLineOutOfBoundsError
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
Test
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)
Next
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)
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 With
End Sub
If you made it this far you deserve an Upvote! I do tend to ramble on.
