Startseite / Tipps / VB 5/6-Tipp 0516: Links in einer Richtextbox wie im Browser

VB 5/6-Tipp 0516: Links in einer Richtextbox wie im Browser

 von Klaus Langbein

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei RichTxtLink.vbp  -----------
' Die Komponente 'Microsoft Rich Textbox Control 6.0 (Richtx32.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: RichTextBox "RichTextBox1"
' Steuerelement: Beschriftungsfeld "lblWord"


' Autoren: K. Langbein Klaus@ActiveVB.de
'          H. Wagner Hirf@ActiveVB.de

' Beschreibung: Siehe InitText()

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    ByRef lParam As Any) As Long
                   
Private Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory _
    As String, ByVal nShowCmd As Long) As Long


Private Const EM_CHARFROMPOS As Long = &HD7&

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Sign(255) As Integer

Sub Highlight(Rtb As RichTextBox)
    Dim pos2 As Long
    Dim pos1 As Long
    Dim br As Long
    Dim lnk As Long
    Dim ret As Long
    Dim l As Long
    Dim Text As String
    Dim Test As String
    
    Text = Rtb.Text
    l = Len(Text$)
    pos1 = 1
    
    Do
        pos2 = InStr(pos1, Text$, " ", 1)
        If pos2 > pos1 Then
            Test = Mid$(Text, pos1, (pos2 - pos1))
            br = RemoveBrackets(Test)
            ret = RemoveSign(Test)
            lnk = IsUrlOrMail(Test)
            
            If lnk > 0 Then
                Rtb.SelStart = pos1 - 1 + br
                Rtb.SelLength = Len(Test)
                
                Select Case lnk
                    Case 1 To 10
                        Rtb.SelColor = vbBlue
                    Case 11 To 20
                        Rtb.SelColor = RGB(0, 127, 0)
                    Case Is > 100
                        Rtb.SelColor = vbRed
                End Select
                
                Rtb.SelBold = True
            Else
                Rtb.SelStart = pos1 - 1
                Rtb.SelLength = Len(Test$)
                Rtb.SelColor = 0
                Rtb.SelBold = False
            End If
            
            pos1 = pos2 + 1
        Else
            If pos2 = pos1 Then
                pos1 = pos2 + 1
            End If
            
        End If
    Loop Until pos2 = 0 Or pos2 >= l
End Sub

Sub InitSigns()
    Dim i As Long
    Dim k As Long
    Dim Test As String
    
    Test = ".,;:?!"
    For i = 1 To Len(Test)
        k = Asc(Mid$(Test, i, 1))
        Sign(k) = 1
    Next i
    
    Test = " " + vbCrLf + Chr$(160)
    For i = 1 To Len(Test)
        k = Asc(Mid$(Test, i, 1))
        Sign(k) = 2
    Next i
End Sub

Sub InitText()
    ' Beispieltext zuweisen.
    RichTextBox1.Text = "In diesem Programm wird demonstriert, wie " _
        & "man in einer Richtextbox eine URL oder E-Mail-Adresse unter " _
        & "dem Mauszeiger erkennt und per Mausklick an den Browser schickt. " _
        & "Dies hier ist z.B. eine gültige URL: http://www.activevb.de . " _
        & "Befindet sich ein Satzzeichen  wie ,;.? oder ! am " _
        & "Ende der Url, wie z.B. hier http://www.activevb.de, so wird das auch " _
        & "berücksichtigt. Auch Klammern oder Anführungszeichen dürfen im Wort unter " _
        & "der Maus sein. Unvollständige URLs so wie wie diese: http://www, " _
        & "werden ausgefiltert. Auch URLs ohne das http:// werden erkannt, wenn " _
        & "sie wenigstens www. und einen weiteren Punkt enthalten, so wie hier: " _
        & "www.activevb.de. Auch E-Mail-Adressen wie, Mail@ActiveVB.de werden " _
        & "hervorgehoben und ggf. an das Mailprogramm geschickt. Links zu Ftp-Servern wie " _
        & "'ftp://ftp.monash.edu.au/pub/win95/programr/vbasic/'" _
        & "werden ebenfalls erkannt." & vbCrLf & vbCrLf
End Sub

Function IsUrlOrMail(Test As String) As Long
    ' Die Url-Erkennung kann natürlich noch verbessert werden.
    ' Die vorliegende Routine hat noch ein paar Schwächen, aber
    ' das ganze soll ja auch schnell gehen.
    
    Dim ok As Long
    Dim pos As Long
    
    pos = InStr(1, Test$, "://", 1)
    If pos > 0 Then
        pos = InStr(1, Test$, "http", 1)
        If pos > 0 Then
            ok = 1
        Else
            pos = InStr(1, Test$, "ftp", 1)
            If pos > 0 Then
                ok = 11
            End If
        End If
        If ok > 0 Then
            pos = InStr(1, Test$, ".", 1)
            If pos = 0 Then
                ok = 0
            End If
        End If
         
    Else
        If LCase(Left$(Test$, 4)) = "www." Then
            pos = InStr(5, Test$, ".", 1)
            If pos > 0 Then
                ok = 5
            End If
        End If
              
    End If
    
    If ok > 0 Then
        IsUrlOrMail = ok
        Exit Function
    End If
    
    pos = InStr(1, Test$, "@", 1)
    If pos > 1 Then
        pos = InStr(pos + 1, Test$, ".", 1)
        If pos > 0 Then
            ok = 101
        End If
    End If

    IsUrlOrMail = ok
End Function

Function RemoveBrackets(Test As String) As Long
    If Left$(Test, 1) = Chr$(40) Then
        If Right(Test, 1) = Chr$(41) Then
            Test = Mid$(Test, 2, Len(Test) - 2)
            RemoveBrackets = 1
        End If
    End If

    If Left$(Test, 1) = Chr$(34) Then
        If Right(Test, 1) = Chr$(34) Then
            Test = Mid$(Test$, 2, Len(Test) - 2)
            RemoveBrackets = 1
        End If
    End If
    
    If Left$(Test, 1) = Chr$(39) Then
        If Right(Test, 1) = Chr$(39) Then
            Test = Mid$(Test, 2, Len(Test) - 2)
            RemoveBrackets = 1
        End If
    End If
End Function

Function RemoveSign(ByRef Test As String) As Long
    Dim Last As Long
    
    Last = Asc(Right$(Test, 1))
    If Sign(Last) = 1 Then
        Test = Left$(Test, Len(Test) - 1)
        RemoveSign = 1
    End If
    
End Function

Sub SendLink(ByVal Link As String)
    Dim Success As Long
    
    'call Shell(url, 1)
    Success = ShellExecute(0&, vbNullString, Link, vbNullString, "C:\", 1)
End Sub

Private Sub Command1_Click()
    Call Highlight(RichTextBox1)
   
    'Beep
End Sub

' very nice
Private Sub Form_Load()
    Call InitSigns
    Call InitText
End Sub

Private Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim Text As String
    Dim lnk As Long
    Dim ret As Long
    
    Text = GetWord(RichTextBox1, x, y)
    If lblWord.Caption <> Text Then
        lblWord.Caption = Text
    End If
    
    lnk = IsUrlOrMail(Text)
    
    If lnk > 0 Then
        ret = RemoveSign(Text)
        ret = RemoveBrackets(Text)
        
        If lnk > 100 Then
            Text = "mailto:" + Text
        End If
        
        'MsgBox Text$
        Call SendLink(Text)
    End If
End Sub

Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, _
    x As Single, y As Single)
    
    Dim Text As String
    
    Text = GetWord(RichTextBox1, x, y)
    If lblWord.Caption <> Text Then lblWord.Caption = Text
    
    If IsUrlOrMail(Text) Then
        RichTextBox1.MousePointer = 99
        'Beep
    Else
        RichTextBox1.MousePointer = 0
    End If
    
End Sub

Private Function GetWord(Rich As RichTextBox, ByVal x&, ByVal y&) As String
    Dim pos As Long, P1 As Long, P2 As Long
    Dim Char As Long
    Dim MousePointer As POINTAPI
    
    ' Position des Textzeichens unter dem Mauszeiger auslesen.
    MousePointer.x = x \ Screen.TwipsPerPixelX
    MousePointer.y = y \ Screen.TwipsPerPixelY
    pos = SendMessage(Rich.hwnd, EM_CHARFROMPOS, 0&, MousePointer)
    If pos <= 0 Then Exit Function
    
    ' Wortanfang finden.
    For P1 = pos To 1 Step -1
        Char = Asc(Mid$(Rich.Text, P1, 1))
        If Sign(Char) = 2 Then
            Exit For
        End If
    Next P1
    P1 = P1 + 1
    
    ' Wortende finden.
    For P2 = pos To Len(Rich.Text)
        Char = Asc(Mid$(Rich.Text, P2, 1))
        If Sign(Char) = 2 Then
            Exit For
        End If
    Next P2
    P2 = P2 - 1
    
    If P1 < P2 Then GetWord = Mid$(Rich.Text, P1, P2 - P1 + 1)
End Function
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------------ Ende Projektdatei RichTxtLink.vbp  ------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

pos2 = InStr(pos1, Text$, " ", 1)
If pos2 = 0 Then
    pos2 = l 'Dies ist ein L, keine 1
End If
If pos2 > pos1 Then

Sub InitSigns()

    Dim i As Long
    Dim k As Long
    Dim Test$
    Test$ = ".,;:?!"
    For i = 1 To Len(Test$)
        k = Asc(Mid$(Test$, i, 1))
        Sign(k) = 1
    Next i

    'Test$ = " " + vbCrLf + Chr$(160)
    'erweitert um Tabulator und Zeichen der RemoveBrackets-    'Funktion <>()'"
    Test$ = " " + vbCrLf + vbTab + Chr$(160) + Chr$(60) _
    + Chr$(62) + Chr$(40) + Chr$(41) + Chr$(34) + Chr$(39)
        For i = 1 To Len(Test$)
        k = Asc(Mid$(Test$, i, 1))
        Sign(k) = 2
    Next i
    
End Sub