打印RichTextbox 方法

Private Sub cmdPrint_Click()
    dlgPrint.Flags = cdlPDReturnDC + cdlPDNoPageNums


    If rtbText.SelLength = 0 Then
        dlgPrint.Flags = dlgPrint.Flags + cdlPDAllPages
    Else
        dlgPrint.Flags = dlgPrint.Flags + cdlPDSelection
    End If
    dlgPrint.ShowPrinter
    PrintRTF rtbText, 1440, 1440, 1440, 1440 ' 1440 Twips = 1 Inch
End Sub
'Printing constants - these should go in


'     form or UserControl Declarations
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 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 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
    'Routine that does the printing


Private Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, TopMarginHeight, _
    RightMarginWidth, BottomMarginHeight)
    On Error Goto ErrorHandler
    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 Print
    '     er.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 Bo
    '     ttom 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 t
    '     o 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_FORMATRAN
        '     GE 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))
ErrorHandler:
End Sub


【VB和.NET专业源码+解决方案+数据字典DVD(全国包快递)】 代码清单 购买后可以享受认证VIP会员及免费获取破解控件补丁