Populate rich text form field with formatted text

Message Topic Search Topic Options Post Reply Create New Topic Printable Version Translate Topic

Option Explicit

Private Enum e_Style
   style_Normal = 0
   style_Bold = 1
   style_Italic = 2
   style_Underline = 4
End Enum

Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long

Public Function RtfToPdfXml(po_Rtb As RichTextLib.RichTextBox) As String
   Const c_ParaStart As String = "<p style="""

   Dim l_Xml As String

   Dim i As Long

   Dim l_OpenNewSpan As Boolean
   Dim l_SpanOpen As Boolean
   Dim l_SpanText As String
   Dim l_ParaStart As Boolean
   Dim l_EmptyParagraph As Boolean

   Dim l_ThisStyle As e_Style ' Current style of the span
   Dim l_LastStyle As e_Style  ' Last style of the span

   Dim l_Color As Long
   Dim l_LastColor As Long

   Dim l_FontName As String
   Dim l_LastFontName As String

   Dim l_FontSize As Single
   Dim l_LastFontSize As Single

   ' Set up the XML header
   l_Xml = "<?xml version=""1.0""?><body xfa:APIVersion=""Acroform:2.7.0.0"" xfa:spec=""2.1"" xmlns=""http://www.w3.org/1999/xhtml"" xmlns:xfa=""http://www.xfa.org/schema/xfa-data/1.0/"" >"

   ' Start first paragraph
   l_Xml = l_Xml & c_ParaStart
   l_ParaStart = True
   l_EmptyParagraph = True

   For i = 0 To Len(po_Rtb.Text) - 1
      With po_Rtb
         .SelStart = i
         .SelLength = 1

         On Error Resume Next
         l_Color = 0
         l_Color = .SelColor
         If l_Color < 0 Then
            l_Color = GetSysColor(l_Color)
         End If
         On Error GoTo 0

         l_FontName = .SelFontName
         l_FontSize = .SelFontSize

         If l_ParaStart Then
            ' Start of a paragraph
            l_ParaStart = False

            ' Handle paragraph alignment
            Select Case .SelAlignment
            Case rtfRight
               l_Xml = l_Xml & "text-align:right;"
            Case rtfCenter
               l_Xml = l_Xml & "text-align:center;"
            Case Else
               l_Xml = l_Xml & "text-align:left;"
            End Select

            ' Handle text color
            l_Xml = l_Xml & "color: " & ColorToPdfXmlRgb(l_Color) & ";"

            ' Handle font face and size
            l_Xml = l_Xml & "font-family: '" & l_FontName & "';"
            l_Xml = l_Xml & "font-size: " & Format$(l_FontSize, "0.0") & "pt;"

            l_Xml = l_Xml & """>"

            ' Reset stored "previous" attributes for new paragraph
            l_SpanOpen = False
            l_OpenNewSpan = False
            l_ThisStyle = style_Normal
            l_LastStyle = style_Normal
            l_LastFontName = ""
            l_LastFontSize = 0
            l_LastColor = vbBlack
         End If

         If (.SelLength = 0) Or (.SelText = vbCr) Or (.SelText = vbLf) Then
            ' New Paragraph
            If .SelLength = 0 Then
               i = i + 1
            End If

            ' Append any buffered span text and close the span if open
            l_Xml = l_Xml & l_SpanText
            l_SpanText = ""
            l_LastStyle = style_Normal
            If l_SpanOpen Then
               l_SpanOpen = False
               l_Xml = l_Xml & "</span>"
            End If

            ' Start new paragraph
            l_Xml = l_Xml & IIf(l_EmptyParagraph, "&#160;", "") & "</p>" & c_ParaStart
            l_ParaStart = True
            l_EmptyParagraph = True

         Else
            ' Continuing processing current paragraph
            l_ThisStyle = style_Normal

            l_EmptyParagraph = False

            ' Handle Bold/Italic/Underline
            ProcessStyle style_Bold, po_Rtb, l_Xml, l_SpanText, l_LastStyle, l_ThisStyle, l_OpenNewSpan, l_SpanOpen
            ProcessStyle style_Italic, po_Rtb, l_Xml, l_SpanText, l_LastStyle, l_ThisStyle, l_OpenNewSpan, l_SpanOpen
            ProcessStyle style_Underline, po_Rtb, l_Xml, l_SpanText, l_LastStyle, l_ThisStyle, l_OpenNewSpan, l_SpanOpen

            If l_Color <> l_LastColor Then
               l_OpenNewSpan = True
            End If
            If l_FontSize <> l_LastFontSize Then
               l_OpenNewSpan = True
            End If
            If l_FontName <> l_LastFontName Then
               l_OpenNewSpan = True
            End If

            If l_OpenNewSpan Then
               ' Text attribute(s) changed
               If l_SpanOpen Then
                  ' Append any buffered span text and close the previous span
                  l_Xml = l_Xml & l_SpanText
                  l_SpanText = ""
                  l_Xml = l_Xml & "</span>"
                  l_SpanOpen = False
               End If

               ' Open a new span
               l_Xml = l_Xml & "<span style="""

               ' Add font styles
               If l_ThisStyle And style_Bold Then
                  l_Xml = l_Xml & "font-weight: bold;"
               End If
               If l_ThisStyle And style_Italic Then
                  l_Xml = l_Xml & "font-style: italic;"
               End If
               If l_ThisStyle And style_Underline Then
                  l_Xml = l_Xml & "text-decoration: underline;"
               End If

               ' Add text color, font family, and font size
               l_Xml = l_Xml & "color: " & ColorToPdfXmlRgb(l_Color) & ";"
               l_Xml = l_Xml & "font-family: '" & l_FontName & "';"
               l_Xml = l_Xml & "font-size: " & Format$(l_FontSize, "0.0") & "pt;"

               l_Xml = l_Xml & """>"
               l_OpenNewSpan = False
               l_SpanOpen = True
            End If

            ' Cache properties for comparison on next loop
            l_LastStyle = l_ThisStyle
            l_LastColor = l_Color
            l_LastFontName = l_FontName
            l_LastFontSize = l_FontSize

            l_SpanText = l_SpanText & .SelText
         End If
      End With
   Next i

   If l_SpanText <> "" Then
      ' Append any buffered text
      l_Xml = l_Xml & l_SpanText
   End If

   If l_SpanOpen Then
      ' Close the open span
      l_Xml = l_Xml & "</span>"
   End If

   If Right$(l_Xml, Len(c_ParaStart)) = c_ParaStart Then
      ' Clean up any orphan paragraph
      l_Xml = Left$(l_Xml, Len(l_Xml) - Len(c_ParaStart))
   Else
      If Right$(l_Xml, 4) <> "</p>" Then
         ' Close an open paragraph
         l_Xml = l_Xml & "</p>"
      End If
   End If

   ' Close the body and return the result
   RtfToPdfXml = l_Xml & "</body>"
End Function

Private Sub ProcessStyle(ByVal p_Style As e_Style, po_Rtb As RichTextLib.RichTextBox, p_Xml As String, p_PreviousTextSpan As String, p_LastStyle As e_Style, p_ThisStyle As e_Style, p_OpenSpan As Boolean, p_SpanOpen As Boolean)
   ' Return TRUE if a new spn should be opened
   Dim l_StyleApplied As Boolean

   Select Case p_Style
   Case style_Underline
      l_StyleApplied = po_Rtb.SelUnderline
   Case style_Italic
      l_StyleApplied = po_Rtb.SelItalic
   Case style_Bold
      l_StyleApplied = po_Rtb.SelBold
   Case Else
      Err.Raise 5
   End Select

   If l_StyleApplied Then
      If p_SpanOpen Then
         If Not CBool(p_LastStyle And p_Style) Then
            p_OpenSpan = True
         End If
      Else
         p_OpenSpan = True
      End If
      p_ThisStyle = p_ThisStyle Or p_Style
   Else
      If p_SpanOpen Then
         If p_LastStyle And p_Style Then
            p_LastStyle = p_LastStyle And Not p_Style
            p_OpenSpan = True
         End If
      Else
         If p_LastStyle And p_Style Then
            p_OpenSpan = True
         End If
      End If
   End If
End Sub

Private Function ColorToPdfXmlRgb(ByVal p_Color As OLE_COLOR) As String
   ' Return a Long color value as a string usable in PDF RichText XML
   ' e.g. Calling ColorToPdfXmlRgb(12624000) returns "rgb(128,160,192)"

   Dim l_Red As Byte
   Dim l_Blue As Byte
   Dim l_Green As Byte

   If p_Color < 0 Then
      p_Color = GetSysColor(p_Color)
   End If

   l_Red = p_Color And &HFF
   l_Green = (p_Color And &HFF00&) \ &H100&
   l_Blue = (p_Color And &HFF0000) \ &H10000

   ColorToPdfXmlRgb = "rgb(" & Format$(l_Red, "000") & "," & Format$(l_Green, "000") & "," & Format$(l_Blue, "000") & ")"
End Function