Option Explicit
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
Private Const BOLDSTART = "[//b]"
Private Const BOLDEND = "[///b]"
Private Const UNDERSTART = "[//u]"
Private Const UNDEREND = "[///u]"
Private Const URLSTART = "[//url]"
Private Const URLEND = "[///url]"
Private Sub Command1_Click()
Dim intStart As Integer
Dim intEnd As Integer
Dim intStart2 As Integer
Dim intEnd2 As Integer
intStart = InStr(1, RichTextBox1.Text, BOLDSTART) + Len(BOLDSTART)
intEnd = InStr(1, RichTextBox1.Text, BOLDEND) - 1
intStart2 = InStr(1, RichTextBox1.Text, UNDERSTART) + Len(UNDERSTART)
intEnd2 = InStr(1, RichTextBox1.Text, UNDEREND) - 1
If intStart > 0 And intEnd > 0 Then
RichTextBox1.SelStart = intStart - 1
RichTextBox1.SelLength = intEnd - intStart + 1
RichTextBox1.SelBold = True
RichTextBox1.SelStart = Len(RichTextBox1.Text)
RichTextBox1.SelBold = False
End If
If intStart2 > 0 And intEnd2 > 0 Then
RichTextBox1.SelStart = intStart2 - 1
RichTextBox1.SelLength = intEnd2 - intStart2 + 1
RichTextBox1.SelUnderline = True
RichTextBox1.SelStart = Len(RichTextBox1.Text)
RichTextBox1.SelUnderline = False
End If
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, BOLDSTART, "")
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, BOLDEND, "")
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, UNDERSTART, "")
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, UNDEREND, "")
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, URLSTART, "")
RichTextBox1.TextRTF = Replace(RichTextBox1.TextRTF, URLEND, "")
DetectURL RichTextBox1, True
End Sub
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 = .TextRTF
' 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
.TextRTF = strText
End With
End Sub
Private Sub Form_Load()
RichTextBox1.Text = "[//b]hi[///b]The URL to click is [url]http://www.vbforums.com[/url]. Please click it." & vbCrLf
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
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