Bonjour,
Je cherche à créer une fonction qui permet d'attacher une URL à un texte donné dans un RichTextBox.
Cette fonction est appelée à l'aide d'un bouton "ajouter un URL" un peu comme celui qui existe dans l'éditeur de message de ce forum
Je n'ai pas trouvé de solution sur étagère. S'il en existe une je suis preneur.
Sinon, j'ai trouvé un contrôle personnalisé qui fait une partie du job, à savoir créer un URL sur un texte donné dans le richtextbox.
Voici le code de ce contrôle :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Ensuite voici comment j'ai utilisé ce contrôle :

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
   Private Sub AddUrlToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles AddUrlToolStripMenuItem.Click
        Dim sUrl As String = InputBox("Entrez l'URL :", "URL")
        Dim sSite As String = rtbDoc.SelectedText
        rtbDoc.InsertLink(rtbDoc.SelectedText, sUrl, rtbDoc.SelectionStart)
 
    End Sub
 
    Private Sub Link_Clicked(sender As Object, e As System.Windows.Forms.LinkClickedEventArgs) Handles rtbDoc.LinkClicked
        System.Diagnostics.Process.Start(e.LinkText.Split("#"c)(1))
    End Sub 'Link_Clicked
Comme je le disais, ça marche pour créer le lien sur un texte sélectionné.
En revanche, mon appli doit ensuite sauvegarder le contenu de ce RTB dans une base de données.
Jusqu'ici, je sauvegardais le Richtextbox1.Rtf
Mais ce RTF ne contient pas d'info sur le lien donc ce dernier n'est pas mémorisé.

Quelle solution puis-je mettre en oeuvre ?

Encore une fois, s'il y a plus simple que de tout redévelopper, je suis preneur, d'autant que ma solution, si j'arrive à la faire marcher, n'est pas aussi sophistiquée qu'un vrai bouton "insérer un lien" standard