@VMJvba

'Честно сознаюсь - основная идея не моя - нарыл где-то в Internet, а вот аранжировка - моя...

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 'переводим из мм ttomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As RECT
Dim rcPage As RECT
Dim NextCharPos As Long

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


oOut.ScaleMode = vbTwips
NextCharPos = 0

' Get the offsett to the printable area on the page in twips
LeftOffset = GetDeviceCaps(oOut.hDC, PHYSICALOFFSETX) / GetDeviceCaps(oOut.hDC, LOGPIXELSX) * 1440
TopOffset = GetDeviceCaps(oOut.hDC, PHYSICALOFFSETY) / GetDeviceCaps(oOut.hDC, LOGPIXELSY) * 1440


' Calculate the Left, Top, Right, and Bottom margins
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (oOut.Width - RightMarginWidth) - LeftOffset
BottomMargin = (oOut.Height - BottomMarginHeight) - TopOffset

rcPage.left = 0
rcPage.top = 0
rcPage.right = oOut.ScaleWidth
rcPage.bottom = oOut.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 = oOut.hDC ' Use the same DC for measuring and rendering
fr.hdcTarget = oOut.hDC ' Point at oOut hDC
'fr.chrg.cpMin = NextCharPos ' Indicate start of text through
fr.chrg.cpMin = 0 ' 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

'oOut.FontSize = 6
oOut.Print Space(1); ' Re-initialize hDC

'NextCharPos = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr) ' Print the page by sending EM_FORMATRANGE message
SendMessage RTF.hwnd, EM_FORMATRANGE, True, fr ' Print the page by sending EM_FORMATRANGE message
'Debug.Print 'OUT EM_FORMATRANGE'; EM_FORMATRANGE
DoEvents
SendMessage RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng(0) 'Похоже восстанавливает исходный RTF
Exit Sub
OutRTFSingleBad:
bError = True
End Sub

'----------- Нет ошибок принтера -----------
Public Sub PrintErrorNo()
bError = False
End Sub

Public Function PrintError() As Boolean
PrintError = bError
End Function

'------ Печать одной страницы без перевода листа -----------
Public Sub PrintRTFSingle(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)
On Error GoTo PrintRTFSingleBad:
Dim LeftOffset As Long
Dim TopOffset As Long
Dim LeftMargin As Long
Dim TopMargin As Long
Dim RightMargin As Long
Dim BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As RECT
Dim rcPage As RECT
'Dim TextLength As Long
Dim NextCharPos As Long
'Dim lPagesCounter As Long 'Число напечатанных страниц
'lPagesCounter = 0

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

bStopRtfPrint = False

NextCharPos = 0
Printer.ScaleMode = vbTwips
<BR

Вернуться к обсуждению:
Проблема с RichTextBox под Windows 2000 или Windows XP VB

0