Snippet Library

none

Add the following code To Form1:
'code:

  Private Const AnInch As Long = 1440   '1440 twips per inch
  Private Const QuarterInch As Long = 360

  Private Sub Form_Load()
  Dim PrintableWidth As Long
  Dim PrintableHeight As Long
  Dim x As Single

  ' Initialize Form and Command button
  Me.Caption = "Rich Text Box WYSIWYG Printing Example"
  Command1.Move 10, 10, 600, 380
  Command1.Caption = "&Print"

  ' Set the font of the RTF to a TrueType font for best results
  RichTextBox1.SelFontName = "Arial"
  RichTextBox1.SelFontSize = 10
                                               
  'initialize the printer object
  x = Printer.TwipsPerPixelX
  Printer.Orientation = vbPRORPortrait  'vbPRORLandscape

  ' Tell the RTF to base it's display off of the printer
  Call WYSIWYG_RTF(RichTextBox1, QuarterInch, QuarterInch, QuarterInch, QuarterInch, PrintableWidth, PrintableHeight) '1440 Twips=1 Inch

  ' Set the form width to match the line width
  Me.Width = PrintableWidth + 200
  Me.Height = PrintableHeight + 800
  End Sub

  Private Sub Form_Resize()
  ' Position the RTF on form
  RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600
  End Sub

  Private Sub Command1_Click()
  ' Print the contents of the RichTextBox with a one inch margin
  PrintRTF RichTextBox1, AnInch, AnInch, AnInch, AnInch
  End Sub


'=================================================
'Insert a new standard module into the project, 'Module1.bas is created by default. 
'=================================================
'Add the following code to Module1: 

'code:

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 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.
'
' LeftMarginWidth - Width of desired left margin in twips
'
' RightMarginWidth - Width of desired right margin in twips
'
' Returns - The length of a line on the printer in twips
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, RightMarginWidth As Long, TopMarginWidth As Long, BottomMarginWidth As Long, PrintableWidth As Long, PrintableHeight As Long)
 Dim LeftOffset As Long
 Dim LeftMargin As Long
 Dim RightMargin As Long
 Dim TopOffset As Long
 Dim TopMargin As Long
 Dim BottomMargin As Long
 Dim PrinterhDC As Long
 Dim 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 = LeftMarginWidth - LeftOffset
 RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
                                          
 ' Calculate the line width
 PrintableWidth = 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 = TopMarginWidth - TopOffset
 BottomMargin = (Printer.Height - BottomMarginWidth) - TopOffset
                                             
 ' Calculate the line width
 PrintableHeight = 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 PrintableWidth)

 ' 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
 '
 ' LeftMarginWidth - Width of desired left margin in twips
 '
 ' TopMarginHeight - Height of desired top margin in twips
 '
 ' RightMarginWidth - Width of desired right margin in twips
 '
 ' BottomMarginHeight - 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 LeftMarginWidth and
 '         RightMarginWidth that you used to call WYSIWYG_RTF()
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _
 TopMarginHeight, RightMarginWidth, BottomMarginHeight)
 Dim LeftOffset As Long, TopOffset As Long
 Dim LeftMargin As Long, TopMargin As Long
 Dim RightMargin As Long, BottomMargin As Long
 Dim fr As FormatRange
 Dim rcDrawTo As Rect
 Dim rcPage As Rect
 Dim TextLength As Long
 Dim NextCharPosition As Long
 Dim r As Long
 ' 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 = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - 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;