Custom Links in Rich Text Box (VB.net)

[itshibu]

Dear all,

I am making a new windows based application for my firm. My appli9cation is developing by vb.net. I accomplished most of the goal except custom links in rich text box.

As my plan the link work with either pictorial or text.
For example. If I am refering a document from another document I want to give a link in document A. once the user press on the link it will be open the another document.
And if I am entering click here in my document, when the user pressing on that it should be raise an event.

I seen one similar example in code project http://www.codeproject.com/KB/edit/RichTextBoxLinks.aspx
But I am not able to implement in my vb.net project.

Kindly help me with your ideas.

Thanks

Shibu

[kvprajapati]

itshibu,

We are so lucky, you got solution for us.

[itshibu]

How you solved the problem?

[kvprajapati]

I solved it by myself. Now, What about your problem?
You said:

I seen one similar example in code project http://www.codeproject.com/KB/edit/R...tBoxLinks.aspx
But I am not able to implement in my vb.net project.

Try to write a code and contact us if you need some help.

[itshibu]

Dear Friend,

Could you please help me to get the VB.net version of that particular program?

[itshibu]

Dear Sir,

I succed to create this work in VB.net But unfortunately if I copy and paste the lik it is not coming as link!!!. did u solved this problem?

Imports System
Imports System.ComponentModel
Imports System.Drawing
Imports System.Windows.Forms
Imports System.Runtime.InteropServices

Namespace RichTextBoxLinks
    Public Class RichTextBoxNew
        Inherits RichTextBox
#Region "Interop-Defines"
        <StructLayout(LayoutKind.Sequential)> _
        Private Structure CHARFORMAT2_STRUCT
            Public cbSize As UInt32
            Public dwMask As UInt32
            Public dwEffects As UInt32
            Public yHeight As Int32
            Public yOffset As Int32
            Public crTextColor As Int32
            Public bCharSet As Byte
            Public bPitchAndFamily As Byte
            <MarshalAs(UnmanagedType.ByValArray, SizeConst:=32)> _
            Public szFaceName As Char()
            Public wWeight As UInt16
            Public sSpacing As UInt16
            Public crBackColor As Integer
            ' Color.ToArgb() -> int
            Public lcid As Integer
            Public dwReserved As Integer
            Public sStyle As Int16
            Public wKerning As Int16
            Public bUnderlineType As Byte
            Public bAnimation As Byte
            Public bRevAuthor As Byte
            Public bReserved1 As Byte
        End Structure

        <DllImport("user32.dll", CharSet:=CharSet.Auto)> _
        Private Shared Function SendMessage(ByVal hWnd As IntPtr, ByVal msg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
        End Function

        Private Const WM_USER As Integer = &H400
        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 UInt32 = &H1
        Private Const CFE_ITALIC As UInt32 = &H2
        Private Const CFE_UNDERLINE As UInt32 = &H4
        Private Const CFE_STRIKEOUT As UInt32 = &H8
        Private Const CFE_PROTECTED As UInt32 = &H10
        Private Const CFE_LINK As UInt32 = &H20
        Private Const CFE_AUTOCOLOR As UInt32 = &H40000000
        Private Const CFE_SUBSCRIPT As UInt32 = &H10000
        ' Superscript and subscript are 
        Private Const CFE_SUPERSCRIPT As UInt32 = &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 UInt32 = &H1
        Private Const CFM_ITALIC As UInt32 = &H2
        Private Const CFM_UNDERLINE As UInt32 = &H4
        Private Const CFM_STRIKEOUT As UInt32 = &H8
        Private Const CFM_PROTECTED As UInt32 = &H10
        Private Const CFM_LINK As UInt32 = &H20
        Private Const CFM_SIZE As UInt32 = &H8000000
        Private Const CFM_COLOR As UInt32 = &H40000000
        Private Const CFM_FACE As UInt32 = &H20000000
        Private Const CFM_OFFSET As UInt32 = &H10000000
        Private Const CFM_CHARSET As UInt32 = &H8000000
        Private Const CFM_SUBSCRIPT As UInt32 = CFE_SUBSCRIPT Or CFE_SUPERSCRIPT
        Private Const CFM_SUPERSCRIPT As UInt32 = 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

        Public Sub New()
            Me.DetectUrls = False
        End Sub

        <DefaultValue(False)> _
        Public Shadows Property DetectUrls() As Boolean
            Get
                Return MyBase.DetectUrls
            End Get
            Set(ByVal value As Boolean)
                MyBase.DetectUrls = value
            End Set
        End Property

        Public Sub InsertLink(ByVal text As String)
            InsertLink(text, Me.SelectionStart)
        End Sub

        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

        Public Sub InsertLink(ByVal text As String, ByVal hyperlink As String)
            InsertLink(text, hyperlink, Me.SelectionStart)
        End Sub

        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

        Public Sub SetSelectionLink(ByVal link As Boolean)
            SetSelectionStyle(CFM_LINK, IIf(link, CFE_LINK, 0))
        End Sub

        Public Function GetSelectionLink() As Integer
            Return GetSelectionStyle(CFM_LINK, CFE_LINK)
        End Function


        Private Sub SetSelectionStyle(ByVal mask As UInt32, ByVal effect As UInt32)
            Dim cf As New CHARFORMAT2_STRUCT()
            cf.cbSize = Convert.ToUInt32(Marshal.SizeOf(cf))
            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

        Private Function GetSelectionStyle(ByVal mask As UInt32, ByVal effect As UInt32) As Integer
            Dim cf As New CHARFORMAT2_STRUCT()
            cf.cbSize = Convert.ToUInt32(Marshal.SizeOf(cf))
            cf.szFaceName = New Char(31) {}

            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_GETCHARFORMAT, wpar, lpar)

            cf = DirectCast(Marshal.PtrToStructure(lpar, GetType(CHARFORMAT2_STRUCT)), CHARFORMAT2_STRUCT)

            Dim state As Integer
            If (cf.dwMask And mask) = mask Then
                If (cf.dwEffects And effect) = effect Then
                    state = 1
                Else
                    state = 0
                End If
            Else
                state = -1
            End If

            Marshal.FreeCoTaskMem(lpar)
            Return state
        End Function
    End Class
End Namespace

[kardsen]

Alright. Got it working after reading this article about namespaces... http://www.aspfree.com/c/a/VB.NET/Developing-Namespaces-in-VBNET-2005/

It had a great article with a demo project!

So I created a new class file in my project then replaced all code in that file with the code listed earlier in this topic

Once I saved the file I went back to my windows form and saw that there was now a RichTextBoxNew control I could add.
I replaced my richtextbox1 with a RichTextBoxNew control, renaming the RichTextBoxNew control to the name of the old RichTextBox which was RichTextBox1

At this point it's all pretty straight forward.

RichTextBox1.InsertLink("linktext", "linkurl.html")   'inserts the link into the new RTB

and then you use the following handler or something similar to raise the event. Remember that e will return both the name and the url so you have to split it!

Private Sub Link_Clicked(ByVal sender As Object, ByVal e As System.Windows.Forms.LinkClickedEventArgs) Handles RichTextBox1.LinkClicked
        Dim UrlLink = Split(e.LinkText, "#")
        If UrlLink.Length > 1 Then System.Diagnostics.Process.Start("IEXPLORE.EXE", UrlLink(1))
    End Sub 'Link_Clicked

[itshibu]

Dear my friend,
Now my problem is this rich textbox not showing the links when ever we copy and paste the another part of the text. and in my project i have to save rtf contents to database and show it again in same rich text box. then also the created link not detecting.
could you please tell me do you have any solution for it?

[kardsen]

Dear my friend,
Now my problem is this rich textbox not showing the links when ever we copy and paste the another part of the text. and in my project i have to save rtf contents to database and show it again in same rich text box. then also the created link not detecting.
could you please tell me do you have any solution for it?

I believe your problem lies in the fact that the RichTextBox does not know how to handle the links how they are formated.

Remember that when using this code, the link you create is actually written out like so:
LINK NAME#http://www.linkname.com

Notice the #

You can see this by copy and pasting the link text from the rich text box to a textfile.

If you are copying data from the richtextbox to another program or application, then back to that richtextbox you will need to have a subroutine that checks for any instance of the #http or however you are formatting your URLS and then have it melodramatically change it back to the format that the Richtextboxnew control can understand.

Specifically you would probably want to use Regex to find the # then have it grab the full string before and after it till it reaches a wordbreak....
Then take that full string... example
LINK NAME#http://www.linkname.com

I am no expert on VB as I have only been using it for about 1 week.. but I would go about your problem in a fashion similar to this.

Sub formatedata()
Dim rr = Regex.Replace(importingfile, "match # string", theinsertlink())
richtextbox1.append(rr)
End Sub

Function theinsertlink(ByVal SrchString As String)
Dim findurls As New Regex("regexstring")
Dim m As Match = findurls.Match(SrchString)

Dim s = Split(m)
s(0) 'being the name
s(1) 'being the link

'Then use the following to insert the link....
Return RichTextBox1.InsertLink(s(0), s(1))
End Function

I am sure there are many things wrong with what I have above since I just wrote it out to give you a VERY rough idea of how one might pull this off.

Good luck and remember to post your results if you figure it out!

Unfortunately I am not very good with regex so you will have to find someone to help you locate the # and grab everything before and after it till a word break and make it a string.