Option Explicit

'Примечание: Microsoft RichTextBox обеспечивает печать самого себя

'с помощью метода .SelPrint.

'К сожалению, данный метод не позволяет никоим образом вмешаться

'в процесс, например для печати на загловков страницы или установки

'отступов от края листа. Данный пример решает эту проблему,

'т.к. теперь Вы имеете полный контроль над процессом печати.

Private Const mFontName As String = "Courier New Cyr"

Private Const cTvip As Single = 56.7 'Твипов на мм

Private bStopRtfPrint As Boolean 'Тормозим печать

Private bError As Boolean 'Ошибка печати

Public Type SIZE

cx As Long

cy As Long

End Type

Public Type RECT

left As Long

top As Long

right As Long

bottom As Long

End Type

Public 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

Public 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

Public Const LOGPIXELSX = 88

Public Const LOGPIXELSY = 90

Public Const PHYSICALOFFSETX As Long = 112

Public Const PHYSICALOFFSETY As Long = 113

Public Const WM_USER As Long = &H400

Public Const EM_FORMATRANGE As Long = WM_USER + 57

'' DrawText() Format Flags

Public Const DT_TOP = &H0

Public Const DT_LEFT = &H0

Public Const DT_CENTER = &H1

Public Const DT_RIGHT = &H2

Public Const DT_VCENTER = &H4

Public Const DT_BOTTOM = &H8

Public Const DT_WORDBREAK = &H10

Public Const DT_SINGLELINE = &H20

Public Const DT_EXPANDTABS = &H40

Public Const DT_TABSTOP = &H80

Public Const DT_NOCLIP = &H100

Public Const DT_EXTERNALLEADING = &H200

Public Const DT_CALCRECT = &H400

Public Const DT_NOPREFIX = &H800

Public Const DT_INTERNAL = &H1000

'------------

'Declare Sub InflateRect Lib "user" (lpRect As RECT, ByVal X%, ByVal Y

Declare Sub InflateRect Lib "user32" (lpRect As RECT, ByVal X%, ByVal Y

Public Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long)

Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long

'--------- Печать текста RTF -------------

Public Sub PrintRTF(RTF As RichTextBox, Optional ByVal LeftMarginWidth As Long = 20, Optional ByVal TopMarginHeight As Long = 10, Optional ByVal RightMarginWidth As Long = 10, Optional ByVal BottomMarginHeight As Long = 10, Optional ByVal bPagesAll As Boolean = True, Optional ByVal lPagesNum As Long = 1)

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, rcPage As RECT

Dim TextLength As Long, NextCharPos As Long

Dim lPagesCounter As Long 'Число напечатанных страниц

lPagesCounter = 0

MmToTwip LeftMarginWidth, TopMarginHeight, RightMarginWidth, BottomMarginHeight 'переводим из мм в Твипы ----------

bStopRtfPrint = False

NextCharPos = 0

Printer.ScaleMode = vbTwips

' Get the offsett to the printable area on the page in twips

LeftOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETX) / GetDeviceCaps(Printer.hDC, LOGPIXELSX) * 1440

TopOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETY) / GetDeviceCaps(Printer.hDC, LOGPIXELSY) * 1440

' 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

' Get length of text in RTF

TextLength = Len(RTF.Text)

' Loop printing each page until done

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 ' Indicate start of text through

fr.chrg.cpMax = -1 ' end of the text

fr.rc = rcDrawTo ' Indicate the area on page to draw to

fr.rcPage = rcPage ' Indicate entire size of page

Printer.Print Space(1) ' Re-initialize hDC

' Print the page by sending EM_FORMATRANGE message

'NextCharPosition = SendMessage(rtf.hwnd, EM_FORMATRANGE, True, fr)

NextCharPos = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr)

'DoEvents

If NextCharPos <= 0 Or NextCharPos >= TextLength Then Exit Do 'If done then exit

DoEvents

If bStopRtfPrint = True Then 'Тормозим печать

GoTo PrintRtfEnd:

End If

If bPagesAll = False Then 'Если задано число страниц с 1 по lPagesNum

lPagesCounter = lPagesCounter + 1

If lPagesCounter >= lPagesNum Then

Exit Do

'GoTo PrintRtfEnd:

End If

End If

Printer.NewPage ' Move on to next page

Loop

' Commit the print job

PrintRtfEnd:

Printer.EndDoc

' Allow the RTF to free up memory

SendMessage RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng(0)

End Sub

'--------------------------------------------------------------------------------

'Использование:

' Напечатать содержимое RichTextBox'a с отступами в 1 дюйм (1440 twips) от края листа

'PrintRTF RichTextBox1, 1440, 1440, 1440, 1440

'Как показала практика этлт метод печати иногда "взбрыкивает" при печати на сетевые принтеры, которые самостоятельно подключены к сети..