richtextbox 如何将部分关键字设置为超链接状态，并通过鼠标点击，获得超链接状态的文本信息？

[lashengcrh]

richtextbox 如何将部分关键字设置为超链接状态，并通过鼠标点击，获得超链接状态的文本信息？

[milaoshu1020]

是要实现这个功能吗:
https://blog.csdn.net/spd260/article/details/79508227

[ypk9999]

试看看这个 http://www.vbforums.com/showthread.php?230073-Detecting-a-URL-in-a-RichTextBox-(Resolved)&s=

[milaoshu1020]

从楼上的地址贴过来的:

Private Const WM_USER As Long = &H400
Private Const EM_AUTOURLDETECT As Long = (WM_USER + 91)
Private Const EM_GETSEL As Long = &HB0
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
     ByVal hwnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     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
 
 
Option Explicit
 
Private Sub DetectURL(p_RichText As Object, p_blnDetect As Boolean)
    Dim lngRet As Long
    Dim strText As String
    
    With p_RichText
        ' this line is needed because the function will not update the
        ' url if you had it before
        strText = .Text
        ' send message to detect urls
        ' notice the Abs function. This is needed to pass 0 or 1
        ' in VB true is -1, so we have to get the absolute value of that
        lngRet = SendMessage(RichTextBox1.hwnd, EM_AUTOURLDETECT, Abs(p_blnDetect), ByVal 0)
        ' rewrite the text into the RichText so it will change all URLs if you
        'had them before
        .Text = strText
    End With
End Sub
 
Private Sub Form_Load()
 
    RichTextBox1.Text = "The URL to click is http://www.something.com.  Please click it."
    
End Sub
 
Private Sub RichTextBox1_Change()
    DetectURL RichTextBox1, True
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
End Sub
 
 
Private Sub RichTextBox1_Click()
 
    Dim lngRetVal As Long
    
    lngRetVal = SendMessage(RichTextBox1.hwnd, EM_GETSEL, 0, 0)
    
    Dim strBuffer As String, intInStr As Integer, intHi As Integer, intLo As Integer
    
    intHi = HiWord(lngRetVal) + 1
    intLo = LoWord(lngRetVal) + 1
    
    intInStr = InStrRev(RichTextBox1.Text, " ", intLo)
    
    If intInStr = 0 Then 'no space
        strBuffer = Mid(RichTextBox1.Text, 1, intLo)
    Else
        strBuffer = Mid(RichTextBox1.Text, intInStr + 1)
    End If
    
    strBuffer = Trim(strBuffer)
    intInStr = InStr(1, strBuffer, " ")
    
    If intInStr <> 0 Then
        strBuffer = Mid(strBuffer, 1, intInStr - 1)
    End If
    
    If InStr(1, strBuffer, "http:") = 0 And _
        InStr(1, strBuffer, "file:") = 0 And _
        InStr(1, strBuffer, "mailto:") = 0 And _
        InStr(1, strBuffer, "ftp:") = 0 And _
        InStr(1, strBuffer, "https:") = 0 And _
        InStr(1, strBuffer, "gopher:") = 0 And _
        InStr(1, strBuffer, "nntp:") = 0 And _
        InStr(1, strBuffer, "prospero:") = 0 And _
        InStr(1, strBuffer, "telnet:") = 0 And _
        InStr(1, strBuffer, "news:") = 0 And _
        InStr(1, strBuffer, "wais:") = 0 Then Exit Sub
        
    Debug.Print strBuffer
    
    'Call ShellExecute(Me.hwnd, "OPEN", strBuffer, vbNullString, vbNullString, 5)
    
End Sub
 
Private Function LoWord(ByVal DWord As Long) As Long
  If DWord And &H8000& Then
    LoWord = DWord Or &HFFFF0000
  Else
    LoWord = DWord And &HFFFF&
  End If
End Function
 
Private Function HiWord(ByVal DWord As Long) As Long
  HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

[lashengcrh]

差不多，vb6能实现吗？

[lashengcrh]

引用 1 楼 milaoshu1020的回复:

是要实现这个功能吗:
https://blog.csdn.net/spd260/article/details/79508227

功能差不多，vb能实现吗？没找到相应的资料

[lashengcrh]

引用 4 楼 ypk9999 的回复:

试看看这个
http://www.vbforums.com/showthread.php?230073-Detecting-a-URL-in-a-RichTextBox-(Resolved)&s=

打不开，有什么办法可以看这个网站
？

[ypk9999]

引用 6 楼 lashengcrh 的回复:

[quote=引用 4 楼 ypk9999 的回复:] 试看看这个 http://www.vbforums.com/showthread.php?230073-Detecting-a-URL-in-a-RichTextBox-(Resolved)&s=

打不开，有什么办法可以看这个网站 ？[/quote] 上面有人转贴该网站那篇的的源码了，所以没需要去原网站，除非你想去那边发问