1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
| 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 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 Sub RTF_TO_PIC(RTF As RichTextBox, Pic As PictureBox)
Dim fr As FormatRange, NextCharPosition As Long, R As Long
Dim rcDrawTo As RECT
Dim rcPage As RECT
Pic.AutoRedraw = False
Pic.Cls
Pic.BackColor = vbWhite
' Set printable area rect
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Pic.ScaleWidth
rcPage.Bottom = Pic.ScaleHeight
' Set rect in which to print (relative to printable area)
rcDrawTo.Left = 0
rcDrawTo.Top = 0
rcDrawTo.Right = Pic.ScaleWidth
rcDrawTo.Bottom = Pic.ScaleHeight
fr.hdc = Pic.hdc ' Use the same DC for measuring and rendering
fr.hdcTarget = Pic.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
NextCharPosition = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr)
R = SendMessage(RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng(0))
Pic.AutoRedraw = True
End Sub
Private Sub Command1_Click()
RTF_TO_PIC RichTextBox1, Picture1
End Sub |
Partager