How to Print from Rich text box control (What you see Is what you get)

Home » Controls » How to Print from Rich text box control (What you see Is what you get)

How to Print from Rich text box control (What you see Is what you get)

Posted on August 22, 2009

Let's say you have Rich text box control in your form and you would like to print, whatever you see in your rich text box control, you would like to print it to the default printer.

Instructions:

Create a new Project
Add a new form to it
Add a Rich Text Box Control RichTextBox1 (To add Rich Text Box Control, you need to add the component using Project > Components and select Microsoft Rich Text Box Control 6.0)
Add a command button Command1
Add a bas module Module1

Now, goto form's code window and add the following code:

Option Explicit
 
Private Sub Form_Load()
  Dim lPrintable_Width As Long
  Dim lPrintable_Height As Long
  Dim X As Single
 
  Command1.Move 12, 12, 620, 390
  Command1.Caption = "&Print"
 
  'Set the font of the Richtext Box Contro to Times New Roman
  RichTextBox1.SelFontName = "Times New Roman"
  RichTextBox1.SelFontSize = 12
 
  'initialize the printer object
  x = Printer.TwipsPerPixelX
  'Set Orientation to Portrait
  Printer.Orientation = vbPRORPortrait
  'Set Orientation to Landscape
  'Printer.Orientation = vbPRORLandscape

  '1440 twips = 1 inch; Setting 1/4 of 1 inch
  Call WYSIWYG_RTF(RichTextBox1, 360, 360, 360, 360, lPrintable_Width, lPrintable_Height)
 
  ' Set the form width to match the line width
  Me.Width = lPrintable_Width + 200
  Me.Height = lPrintable_Height + 800
End Sub
 
Private Sub Form_Resize()
  'Re-Position the Richtext box control when the form is resized
  RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600
End Sub
 
Private Sub Command1_Click()
  'Print the contents of the RichTextBox with one inch margin (1440 twips = 1 inch)
  PrintRTF RichTextBox1, 1440, 1440, 1440, 1440
End Sub

Add the following code in a bas module:

Option Explicit
 
Private Type Rect
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Type CharRange
  'First character of range (0 for start of doc)
  cpMin As Long
  'Last character of range (-1 for end of doc)
  cpMax As Long
End Type
 
Private Type FormatRange
  'Actual DC to draw on
  hdc As Long
  'Target DC for determining text formatting
  hdcTarget As Long
  'Region of the DC to draw to (in twips)
  rc As Rect
  'Region of the entire DC (page size) (in twips)
  rcPage As Rect
  'Range of text to draw (see above declaration)
  chrg As CharRange
End Type
 
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
 
'WYSIWYG_RTF - Sets an RTF control to display itself the same as it would print on the default printer
'
'RTF - A RichTextBox control to set for WYSIWYG display.
'lLeft_Margin_Width - Width of desired left margin in twips
'lRight_Margin_Width - Width of desired right margin in twips
'lTop_Margin_Width - Width of desired top margin in twips
'lBottom_Margin_Width - Width of desired bottom margin in twips
'lPrintable_Width - Width of desired Printable area in twips
'lPrintable_Height - Height of desired Printable area in twips
'Returns - The length of a line on the printer in twips
Public Sub WYSIWYG_RTF(RTF As RichTextBox, ByRef lPrintable_Width As Long, ByRef lPrintable_Height As Long, Optional ByVal lLeft_Margin_Width As Long = 360, Optional ByVal lRight_Margin_Width As Long = 360, Optional ByVal lTop_Margin_Width As Long = 360, Optional ByVal lBottom_Margin_Width As Long = 360)
    Dim LeftOffset As Long, LeftMargin As Long, RightMargin As Long, TopOffset As Long, TopMargin As Long, BottomMargin As Long, PrinterhDC As Long, R As Long
 
  'Start a print job to initialize printer object
  Printer.Print Space(1)
  Printer.ScaleMode = vbTwips
 
  'Get the left offset to the printable area on the page in twips
  LeftOffset = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX)
  LeftOffset = Printer.ScaleX(LeftOffset, vbPixels, vbTwips)
 
  'Calculate the Left, and Right margins
  LeftMargin = lLeft_Margin_Width - LeftOffset
  RightMargin = (Printer.Width - lRight_Margin_Width) - LeftOffset
 
  'Calculate the line width
  lPrintable_Width = RightMargin - LeftMargin
 
  'Get the top offset to the printable area on the page in twips
  TopOffset = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY)
  TopOffset = Printer.ScaleX(TopOffset, vbPixels, vbTwips)
 
  'Calculate the Left, and Right margins
  TopMargin = lTop_Margin_Width - TopOffset
  BottomMargin = (Printer.Height - lBottom_Margin_Width) - TopOffset
 
  'Calculate the line width
  lPrintable_Height = BottomMargin - TopMargin
 
  'Create an hDC on the Printer pointed to by the Printer object
  'This DC needs to remain for the RTF to keep up the WYSIWYG display
  PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
 
  'Tell the RTF to base it's display off of the printer at the desired line width
  R = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, ByVal lPrintable_Width)
 
  'Abort the temporary print job used to get printer info
  Printer.KillDoc
End Sub
 
'PrintRTF - Prints the contents of a RichTextBox control using the provided margins
'RTF - A RichTextBox control to print
'lLeft_Margin_Width - Width of desired left margin in twips
'lTop_Margin_Height - Height of desired top margin in twips
'lRight_Margin_Width - Width of desired right margin in twips
'lBottom_Margin_Height - Height of desired bottom margin in twips
'Notes - If you are also using WYSIWYG_RTF() on the provided RTF parameter you should specify the same lLeft_Margin_Width and lRight_Margin_Width that you used to call WYSIWYG_RTF()
Public Sub PrintRTF(RTF As RichTextBox, lLeft_Margin_Width As Long, lTop_Margin_Height, lRight_Margin_Width, lBottom_Margin_Height)
  Dim LeftOffset As Long, TopOffset As Long, LeftMargin As Long, TopMargin As Long, RightMargin As Long, BottomMargin As Long
  Dim TextLength As Long, NextCharPosition As Long, R As Long
  Dim rcDrawTo As Rect, rcPage As Rect
  Dim Fr As FormatRange
 
  'Start a print job to get a valid Printer.hDC
  Printer.Print Space(1)
  Printer.ScaleMode = vbTwips
 
  'Get the offsett to the printable area on the page in twips
  LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX), vbPixels, vbTwips)
  TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY), vbPixels, vbTwips)
 
  'Calculate the Left, Top, Right, and Bottom margins
  LeftMargin = lLeft_Margin_Width - LeftOffset
  TopMargin = lTop_Margin_Height - TopOffset
  RightMargin = (Printer.Width - lRight_Margin_Width) - LeftOffset
  BottomMargin = (Printer.Height - lBottom_Margin_Height) - TopOffset
 
  'Set printable area rect
  rcPage.Left = 0
  rcPage.Top = 0
  rcPage.Right = Printer.ScaleWidth
  rcPage.Bottom = Printer.ScaleHeight
 
  'Set rect in which to print (relative to printable area)
  rcDrawTo.Left = LeftMargin
  rcDrawTo.Top = TopMargin
  rcDrawTo.Right = RightMargin
  rcDrawTo.Bottom = BottomMargin
 
  'Set up the print instructions
  Fr.hdc = Printer.hdc 'Use the same DC for measuring and rendering
  Fr.hdcTarget = Printer.hdc 'Point at printer hDC
  Fr.rc = rcDrawTo 'Indicate the area on page to draw to
  Fr.rcPage = rcPage 'Indicate entire size of page
  Fr.chrg.cpMin = 0 'Indicate start of text through
  Fr.chrg.cpMax = -1 'end of the text

  'Get length of text in RTF
  TextLength = Len(RTF.Text)
 
  'Loop printing each page until done
  Do
    'Print the page by sending EM_FORMATRANGE message
    NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, Fr)
    If NextCharPosition >= TextLength Then Exit Do 'If done then exit
    Fr.chrg.cpMin = NextCharPosition 'Starting position for next page
    Printer.NewPage 'Move on to next page
    Printer.Print Space(1) 'Re-initialize hDC
    Fr.hdc = Printer.hdc
    Fr.hdcTarget = Printer.hdc
  Loop
 
  'Commit the print job
  Printer.EndDoc
 
  'Allow the RTF to free up memory
  R = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub