VB 5/6-Tipp 0516: Links in einer Richtextbox wie im Browser
von Klaus Langbein
Beschreibung
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.
Viele Filterfunktion erlauben eine eindeutige Identifizierung von URLs und Mail-Adressen.
Dieser Tipp entstand in Zusammenarbeit von Herfried K. Wagner und Klaus Langbein.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: | Download: |
'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 |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.
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.
Kommentar von skyworker am 19.01.2007 um 12:52
Wenn am ende des textes ein Hyperlink steht, ignoriert ihn die Funktion "Hilight". Es fehlt folgende IF-Anweisung
pos2 = InStr(pos1, Text$, " ", 1)
If pos2 = 0 Then
pos2 = l 'Dies ist ein L, keine 1
End If
If pos2 > pos1 Then
Kommentar von André Geese am 25.04.2006 um 14:49
Hallo,
ich habe da ein dringendes Problem: Ich möchte per Klick alle Werte die innerhalb [stell]...[/stell] in der Richtextbox stehen als Link darstellen.
Ich bekomme es einfach nicht, können Sie mir da helfen?
Vielen Dank
Gruß
André Geese
Kommentar von André Geese am 25.04.2006 um 14:49
Hallo,
ich habe da ein dringendes Problem: Ich möchte per Klick alle Werte die innerhalb [stell]...[/stell] in der Richtextbox stehen als Link darstellen.
Ich bekomme es einfach nicht, können Sie mir da helfen?
Vielen Dank
Gruß
André Geese
Kommentar von Klaus-Peter Giese am 27.04.2005 um 14:53
Kleiner Verbesserungsvorschlag:
Die Funktion RemoveBrackets ganz streichen und dafür
InitSigns wie folgt erweitern:
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
Funktioniert gut. Danke.
Klaus