Option Explicit
Dim Colors As New Collection
Private Sub Command1_Click()
With RichTextBox1
.Visible = False 'Hide RTB to Prevents Flickering
.Text = "" 'Clears previous text and formating
.Text = "<B><U><FontName=Arial><FontSize=12>" & _
"<Color=Red>The</U></B> </Color=Red></FontSize=12>" & _
"<Color=Blue><B><FontSize=16>quick</FontSize=16> " & _
"</Color=Blue><Color=Brown></B><I><FontSize=18> brown" & _
"</FontSize=18></I></Color=Brown><Color=Purple> fox" & _
"</Color=Purple></Color=Red></B></FontName=Arial>" & _
vbNewLine & vbNewLine & vbNewLine & _
"<Left><B>Left</B></Left>" & vbNewLine & _
"<Center><B>Center</B></Center>" & vbNewLine & _
"<Right><B>Right</B></Right>"
Call RichTextBoxFormat(RichTextBox1)
.Visible = True
End With
End Sub
Private Sub Form_Load()
With Colors 'Collection for Colors
.Add vbRed, "Red"
.Add vbBlue, "Blue"
.Add vbGreen, "Green"
.Add vbYellow, "Yellow"
.Add &H80FF&, "Orange"
.Add vbWhite, "White"
.Add vbBlack, "Black"
.Add &HC0C000, "LtBlue"
.Add &HFF00FF, "Purple"
.Add &H404080, "Brown"
End With
End Sub
Private Sub RichTextBoxFormat(RTB As RichTextBox)
Dim lngTag_Start As Long
Dim lngTag_End As Integer
Dim strTag_Start As String
Dim strTag_End As String
Dim strText As String
Dim a As Long
For a = 1 To 31
strTag_Start = "<" & Choose(a, "B", "I", "U", "Center", "Left", _
"Right", "Color=Red", "Color=Blue", _
"Color=Green", "Color=Yellow", _
"Color=Orange", "Color=White", _
"Color=Black", "Color=LtBlue", _
"Color=Purple", "Color=Brown", _
"FontSize=8", "FontSize=10", "FontSize=12", _
"FontSize=14", "FontSize=16", "FontSize=18", _
"FontSize=20", "FontSize=22", "FontSize=24", _
"FontName=Arial", "FontName=Arial Black", _
"FontName=Comic Sans MS", _
"FontName=French Script MT", _
"FontName=Lucida Console", _
"FontName=Old English Text", _
"FontName=New Times Roman", _
"FontName=EAN-13", "FontName=UPCA", _
"FontName=UPCA", "FontName=UPC-E Short", _
"FontName=3 of 9 Barcode") & ">"
strTag_End = "</" & Mid(strTag_Start, 2)
lngTag_End = 1
With RTB
strText = .Text
Do While InStr(lngTag_End, strText, strTag_Start) > 0
'Loops through the text to find each tag
.SelLength = 0
lngTag_Start = InStr(lngTag_End, strText, strTag_Start)
lngTag_End = InStr(lngTag_Start, strText, strTag_End)
.SelStart = lngTag_Start + Len(strTag_Start) - 1
.SelLength = ((lngTag_End - lngTag_Start) - Len(strTag_End)) + 1
Select Case strTag_Start 'Formats the text based upon tag
Case "<B>" 'Bold Text
.SelBold = True
Case "<I>" 'Italic Text
.SelItalic = True
Case "<U>" 'Underline Text
.SelUnderline = True
Case "<Center>" 'Center Align Text
.SelAlignment = rtfCenter
Case "<Left>" 'Left Align Text
.SelAlignment = rtfLeft
Case "<Right>" 'Right Align Text
.SelAlignment = rtfRight
Case Else
If InStr(strTag_Start, "Color") > 0 Then 'Colors Text
.SelColor = Colors.Item((Mid(strTag_Start, 8, Len(strTag_Start) - 8)))
ElseIf InStr(strTag_Start, "FontSize") > 0 Then 'Font Size
.SelFontSize = (Mid(strTag_Start, 11, Len(strTag_Start) - 11))
ElseIf InStr(strTag_Start, "FontName") > 0 Then 'Font Name
.SelFontName = (Mid(strTag_Start, 11, Len(strTag_Start) - 11))
End If
End Select
lngTag_End = lngTag_End + 1
Loop 'Check text for additional tags
'Removes the Tags from the RichTextBox
Do While .Find(strTag_Start, 0) <> -1
.SelText = ""
Loop
Do While .Find(strTag_End, 0) <> -1
.SelText = ""
Loop
.SelStart = 1
End With
Next a
End Sub