Option Explicit
Public 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 LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const PHYSICALOFFSETX
As Long = 112
Private Const PHYSICALOFFSETY
As Long = 113
Private Const WM_USER
As Long = &H400
Private Const EM_FORMATRANGE
As Long = WM_USER + 57
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
Public Declare Function DrawText
Lib "user32"
Alias "

rawTextA" (
ByVal hDC
As Long,
ByVal lpStr
As String,
ByVal nCount
As Long, lpRect
As RECT,
ByVal wFormat
As Long)
As Long
'Public Declare Function DrawTextEx Lib "user32" Alias "
rawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Public Sub PrintRTF(rtf
As RichTextBox, LeftMarginWidth
As Long, TopMarginHeight, RightMarginWidth, BottomMarginHeight,
Optional Text$)
Dim LeftOffset&, TopOffset&, LeftMargin&, TopMargin&
Dim RightMargin&, BottomMargin&
Dim rcDrawTo
As RECT, rcPage
As RECT
Dim TextLength&, NextCharPos&
Dim fr
As FormatRange, Page&, tmp$
NextCharPos = 0
Page = 1
Printer.ScaleMode = vbTwips
LeftOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETX) / GetDeviceCaps(Printer.hDC, LOGPIXELSX) * 1440
TopOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETY) / GetDeviceCaps(Printer.hDC, LOGPIXELSY) * 1440
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin
TextLength = Len(rtf.Text)
Do
' 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.chrg.cpMin = NextCharPos
fr.chrg.cpMax = -1
fr.rc = rcDrawTo
' Indicate the area on page to draw to
fr.rcPage = rcPage
' Indicate entire size of page
Printer.Print Space(1)
tmp = "HTML EXpert " & Text
'& Chr$(32) & LanguageNow(113) & Chr$(32) & Page
DrawText Printer.hDC, tmp,
Len(tmp), MakeRect(10, 10, Printer.Width, 700), 0
tmp = LanguageNow(113) & Chr$(32) & Page
DrawText Printer.hDC, tmp,
Len(tmp), MakeRect(Printer.Width / Printer.TwipsPerPixelX - Printer.TextWidth(tmp), 10, Printer.Width, 700), 0
NextCharPos = SendMessage(rtf.hwnd, EM_FORMATRANGE,
True, fr)
If NextCharPos <= 0
Or NextCharPos >= TextLength
Then Exit Do
Printer.NewPage
Page = Page + 1
MsgBox Page
Loop
Printer.EndDoc
' Allow the RTF to free up memory
SendMessage rtf.hwnd, EM_FORMATRANGE,
False,
ByVal CLng(0)
End Sub
Public Function MakeRect(Left&, Top&, Right&, Bottom&
As RECT
With MakeRect
.Bottom = Bottom
.Left = Left
.Right = Right
.Top = Top
End With
End Function