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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
| Option Explicit On
Imports System
Imports System.Windows.Forms
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Drawing.Printing
''' <summary>
''' The rich text box print control class was developed by Microsoft, information about
''' this control can be found in your help files at:
''' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.KB.v10.en/enu_kbvbnetkb/vbnetkb/811401.htm
''' In general, their intent was to create a rich text box control with print capability
''' embedded into the control.
''' </summary>
''' <remarks>This control class replaces the use of the regular RichTextBox control; the
''' purpose of this extension was specifically to facilitate printing the contents
''' of a rich text box control.</remarks>
Public Class RichTextBoxPrintCtrl
Inherits RichTextBox
' Convert the unit that is used by the .NET framework (1/100 inch)
' and the unit that is used by Win32 API calls (twips 1/1440 inch)
Private Const AnInch As Double = 14.4
<StructLayout(LayoutKind.Sequential)> _
Private Structure RECT
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
<StructLayout(LayoutKind.Sequential)> _
Private Structure CHARRANGE
Public cpMin As Integer ' First character of range (0 for start of doc)
Public cpMax As Integer ' Last character of range (-1 for end of doc)
End Structure
<StructLayout(LayoutKind.Sequential)> _
Private Structure FORMATRANGE
Public hdc As IntPtr ' Actual DC to draw on
Public hdcTarget As IntPtr ' Target DC for determining text formatting
Public rc As Rect ' Region of the DC to draw to (in twips)
Public rcPage As Rect ' Region of the whole DC (page size) (in twips)
Public chrg As CHARRANGE ' Range of text to draw (see above declaration)
End Structure
Private Const WM_USER As Integer = &H400
Private Const EM_FORMATRANGE As Integer = WM_USER + 57
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As IntPtr, ByVal msg As Integer, ByVal wp As IntPtr, ByVal lp As IntPtr) As IntPtr
' Render the contents of the RichTextBox for printing
' Return the last character printed + 1 (printing start from this point for next page)
Public Function Print(ByVal charFrom As Integer, ByVal charTo As Integer, ByVal e As PrintPageEventArgs) As Integer
' Mark starting and ending character
Dim cRange As CHARRANGE
cRange.cpMin = charFrom
cRange.cpMax = charTo
' Calculate the area to render and print
Dim rectToPrint As RECT
rectToPrint.Top = e.MarginBounds.Top * AnInch
rectToPrint.Bottom = e.MarginBounds.Bottom * AnInch
rectToPrint.Left = e.MarginBounds.Left * AnInch
rectToPrint.Right = e.MarginBounds.Right * AnInch
' Calculate the size of the page
Dim rectPage As RECT
rectPage.Top = e.PageBounds.Top * AnInch
rectPage.Bottom = e.PageBounds.Bottom * AnInch
rectPage.Left = e.PageBounds.Left * AnInch
rectPage.Right = e.PageBounds.Right * AnInch
Dim hdc As IntPtr = e.Graphics.GetHdc()
Dim fmtRange As FORMATRANGE
fmtRange.chrg = cRange ' Indicate character from to character to
fmtRange.hdc = hdc ' Use the same DC for measuring and rendering
fmtRange.hdcTarget = hdc ' Point at printer hDC
fmtRange.rc = rectToPrint ' Indicate the area on page to print
fmtRange.rcPage = rectPage ' Indicate whole size of page
Dim res As IntPtr = IntPtr.Zero
Dim wparam As IntPtr = IntPtr.Zero
wparam = New IntPtr(1)
' Move the pointer to the FORMATRANGE structure in memory
Dim lparam As IntPtr = IntPtr.Zero
lparam = Marshal.AllocCoTaskMem(Marshal.SizeOf(fmtRange))
Marshal.StructureToPtr(fmtRange, lparam, False)
' Send the rendered data for printing
res = SendMessage(Handle, EM_FORMATRANGE, wparam, lparam)
' Free the block of memory allocated
Marshal.FreeCoTaskMem(lparam)
' Release the device context handle obtained by a previous call
e.Graphics.ReleaseHdc(hdc)
' Return last + 1 character printer
Return res.ToInt32()
End Function
#Region "Interop-Defines"
<StructLayout(LayoutKind.Sequential)> _
Private Structure CHARFORMAT2_STRUCT
Public cbSize As Integer
Public dwMask As Integer
Public dwEffects As Integer
Public yHeight As Integer
Public yOffset As Integer
Public crTextColor As Integer
Public bCharSet As Byte
Public bPitchAndFamily As Byte
<MarshalAs(UnmanagedType.ByValArray, SizeConst:=32)> _
Public szFaceName As Char()
Public wWeight As Short
Public sSpacing As Short
Public crBackColor As Integer
' Color.ToArgb() -> int
Public lcid As Integer
Public dwReserved As Integer
Public sStyle As Short
Public wKerning As Short
Public bUnderlineType As Byte
Public bAnimation As Byte
Public bRevAuthor As Byte
Public bReserved1 As Byte
End Structure
Private Const EM_GETCHARFORMAT As Integer = WM_USER + 58
Private Const EM_SETCHARFORMAT As Integer = WM_USER + 68
Private Const SCF_SELECTION As Integer = &H1
Private Const SCF_WORD As Integer = &H2
Private Const SCF_ALL As Integer = &H4
#Region "CHARFORMAT2 Flags"
Private Const CFE_BOLD As Integer = &H1
Private Const CFE_ITALIC As Integer = &H2
Private Const CFE_UNDERLINE As Integer = &H4
Private Const CFE_STRIKEOUT As Integer = &H8
Private Const CFE_PROTECTED As Integer = &H10
Private Const CFE_LINK As Integer = &H20
Private Const CFE_AUTOCOLOR As Integer = &H40000000
Private Const CFE_SUBSCRIPT As Integer = &H10000
' Superscript and subscript are
Private Const CFE_SUPERSCRIPT As Integer = &H20000
' mutually exclusive
Private Const CFM_SMALLCAPS As Integer = &H40
' (*)
Private Const CFM_ALLCAPS As Integer = &H80
' Displayed by 3.0
Private Const CFM_HIDDEN As Integer = &H100
' Hidden by 3.0
Private Const CFM_OUTLINE As Integer = &H200
' (*)
Private Const CFM_SHADOW As Integer = &H400
' (*)
Private Const CFM_EMBOSS As Integer = &H800
' (*)
Private Const CFM_IMPRINT As Integer = &H1000
' (*)
Private Const CFM_DISABLED As Integer = &H2000
Private Const CFM_REVISED As Integer = &H4000
Private Const CFM_BACKCOLOR As Integer = &H4000000
Private Const CFM_LCID As Integer = &H2000000
Private Const CFM_UNDERLINETYPE As Integer = &H800000
' Many displayed by 3.0
Private Const CFM_WEIGHT As Integer = &H400000
Private Const CFM_SPACING As Integer = &H200000
' Displayed by 3.0
Private Const CFM_KERNING As Integer = &H100000
' (*)
Private Const CFM_STYLE As Integer = &H80000
' (*)
Private Const CFM_ANIMATION As Integer = &H40000
' (*)
Private Const CFM_REVAUTHOR As Integer = &H8000
Private Const CFM_BOLD As Integer = &H1
Private Const CFM_ITALIC As Integer = &H2
Private Const CFM_UNDERLINE As Integer = &H4
Private Const CFM_STRIKEOUT As Integer = &H8
Private Const CFM_PROTECTED As Integer = &H10
Private Const CFM_LINK As Integer = &H20
Private Const CFM_SIZE As Integer = &H80000000
Private Const CFM_COLOR As Integer = &H40000000
Private Const CFM_FACE As Integer = &H20000000
Private Const CFM_OFFSET As Integer = &H10000000
Private Const CFM_CHARSET As Integer = &H8000000
Private Const CFM_SUBSCRIPT As Integer = CFE_SUBSCRIPT Or CFE_SUPERSCRIPT
Private Const CFM_SUPERSCRIPT As Integer = CFM_SUBSCRIPT
Private Const CFU_UNDERLINENONE As Byte = &H0
Private Const CFU_UNDERLINE As Byte = &H1
Private Const CFU_UNDERLINEWORD As Byte = &H2
' (*) displayed as ordinary underline
Private Const CFU_UNDERLINEDOUBLE As Byte = &H3
' (*) displayed as ordinary underline
Private Const CFU_UNDERLINEDOTTED As Byte = &H4
Private Const CFU_UNDERLINEDASH As Byte = &H5
Private Const CFU_UNDERLINEDASHDOT As Byte = &H6
Private Const CFU_UNDERLINEDASHDOTDOT As Byte = &H7
Private Const CFU_UNDERLINEWAVE As Byte = &H8
Private Const CFU_UNDERLINETHICK As Byte = &H9
Private Const CFU_UNDERLINEHAIRLINE As Byte = &HA
' (*) displayed as ordinary underline
#End Region
#End Region
''' <summary>
''' Insert a given text as a link into the RichTextBox at the current insert position.
''' </summary>
''' <param name="text">Text to be inserted</param>
Public Sub InsertLink(ByVal text As String)
InsertLink(text, Me.SelectionStart)
End Sub
''' <summary>
''' Insert a given text at a given position as a link.
''' </summary>
''' <param name="text">Text to be inserted</param>
''' <param name="position">Insert position</param>
Public Sub InsertLink(ByVal text As String, ByVal position As Integer)
If position < 0 OrElse position > Me.Text.Length Then
Throw New ArgumentOutOfRangeException("position")
End If
Me.SelectionStart = position
Me.SelectedText = text
Me.[Select](position, text.Length)
Me.SetSelectionLink(True)
Me.[Select](position + text.Length, 0)
End Sub
''' <summary>
''' Insert a given text at at the current input position as a link.
''' The link text is followed by a hash (#) and the given hyperlink text, both of
''' them invisible.
''' When clicked on, the whole link text and hyperlink string are given in the
''' LinkClickedEventArgs.
''' </summary>
''' <param name="text">Text to be inserted</param>
''' <param name="hyperlink">Invisible hyperlink string to be inserted</param>
Public Sub InsertLink(ByVal text As String, ByVal hyperlink As String)
InsertLink(text, hyperlink, Me.SelectionStart)
End Sub
''' <summary>
''' Insert a given text at a given position as a link. The link text is followed by
''' a hash (#) and the given hyperlink text, both of them invisible.
''' When clicked on, the whole link text and hyperlink string are given in the
''' LinkClickedEventArgs.
''' </summary>
''' <param name="text">Text to be inserted</param>
''' <param name="hyperlink">Invisible hyperlink string to be inserted</param>
''' <param name="position">Insert position</param>
Public Sub InsertLink(ByVal text As String, ByVal hyperlink As String, ByVal position As Integer)
If position < 0 OrElse position > Me.Text.Length Then
Throw New ArgumentOutOfRangeException("position")
End If
Me.SelectionStart = position
Me.SelectedRtf = "{\rtf1\ansi " & text & "\v #" & hyperlink & "\v0}"
Me.[Select](position, text.Length + hyperlink.Length + 1)
Me.SetSelectionLink(True)
Me.[Select](position + text.Length + hyperlink.Length + 1, 0)
End Sub
''' <summary>
''' Set the current selection's link style
''' </summary>
''' <param name="link">true: set link style, false: clear link style</param>
Public Sub SetSelectionLink(ByVal link As Boolean)
SetSelectionStyle(CFM_LINK, If(link, CFE_LINK, 0))
End Sub
Private Sub SetSelectionStyle(ByVal mask As Integer, ByVal effect As Integer)
Dim cf As New CHARFORMAT2_STRUCT()
cf.cbSize = CType(Marshal.SizeOf(cf), Integer)
cf.dwMask = mask
cf.dwEffects = effect
Dim wpar As New IntPtr(SCF_SELECTION)
Dim lpar As IntPtr = Marshal.AllocCoTaskMem(Marshal.SizeOf(cf))
Marshal.StructureToPtr(cf, lpar, False)
Dim res As IntPtr = SendMessage(Handle, EM_SETCHARFORMAT, wpar, lpar)
Marshal.FreeCoTaskMem(lpar)
End Sub
End Class |
Partager