Convert RTF to PDF

Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type CharRange
     cpMin As Long     ' First character of range (0 for start of doc)
     cpMax As Long     ' Last character of range (-1 for end of doc)
End Type

Private Type FormatRange
     hDc As Long       ' Actual DC to draw on
     hdcTarget As Long ' Target DC for determining text formatting
     rc As RECT        ' Region of the DC to draw to (in twips)
     RcPage As RECT    ' Region of the entire DC (page size) (in twips)
     chrg As CharRange ' Range of text to draw (see above declaration)
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Dim Doc As New QuickPDFAX0717.PDFLibrary
Private Sub Form_Load()
  Doc.UnlockKey "j53g77ru93q3ds9kw7ru59b8y" 'trial key
  'Size RichTextBox1 to A4 format
  RichTextBox1.Move 0, 0, ScaleX(210, vbMillimeters, vbTwips), ScaleY(297, vbMillimeters, vbTwips)
  'load some test file
  RichTextBox1.LoadFile App.Path & "\Test.rtf"
End Sub

Private Sub Command1_Click()
  Dim Dc As Long
  Dim PageNumber As Long
  Dim LastChar As Long
  Dim DocId As Long
  PageNumber = 1
  LastChar = 0
  Do
    'get a virtual device context size at A4
    Dc = Doc.GetCanvasDC(ScaleX(210, vbMillimeters, vbPixels), ScaleY(297, vbMillimeters, vbPixels))
    'print the rtfbox
    LastChar = ImprimeRtfBox(Dc, RichTextBox1, LastChar)
    'generate a new document
    Doc.LoadFromCanvasDc 96, 0
    DocId = Doc.SelectedDocument
    'save it to file
    Doc.SaveToFile App.Path & "\Test" & CStr(PageNumber) & ".pdf"
    'remove it from memory
    Doc.RemoveDocument DocId
    PageNumber = PageNumber + 1
  Loop While LastChar <> 0
  MsgBox "Done"
End Sub

Public Function ImprimeRtfBox(hDc As Long, rtfBox As RichTextBox, FirstChar As Long)
  Dim RcDrawTo As RECT
  Dim RcPage As RECT
  Dim Fr As FormatRange
  Dim NextCharPosition As Long
      RcPage.Left = 0
      RcPage.Right = rtfBox.Left + rtfBox.Width + 100
      RcPage.Top = 0
      RcPage.Bottom = rtfBox.Top + rtfBox.Height + 100
      RcDrawTo.Left = rtfBox.Left
      RcDrawTo.Top = rtfBox.Top
      RcDrawTo.Right = rtfBox.Left + rtfBox.Width
      RcDrawTo.Bottom = rtfBox.Top + rtfBox.Height
      Fr.hDc = hDc
      Fr.hdcTarget = hDc
      Fr.rc = RcDrawTo
      Fr.RcPage = RcPage
      Fr.chrg.cpMin = FirstChar
      Fr.chrg.cpMax = -1
      NextCharPosition = SendMessage(rtfBox.hWnd, EM_FORMATRANGE, True, Fr)
    If NextCharPosition < Len(rtfBox.text) Then
      ImprimeRtfBox = NextCharPosition
    Else
      ImprimeRtfBox = 0
    End If
End Function