Option Explicit

'local variable to hold collection
Private mCol As Collection
'reference a RTF box control
Public WithEvents RichTextBox As RichTextBox
'API declaration
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

'Const values used with SendMessage
Private Const EM_GETLINE = &HC4
Private Const EM_LINEFROMCHAR = &HC9
Private Const EM_LINEINDEX = &HBB

'This const value is set to the maximum length allowed of
'one line in the RTF box.
'No checks are performed though so the code
'in the RichTextBox_Click event might fail if the line of
'text is longer then this value!!!!
Private Const MAXLINELENGTH = 512

Public Function Add(LinkText As String, LinkURL As String, Optional sKey As String) As CHyperlink
    'create a new object
    Dim objNewMember As CHyperlink
    Set objNewMember = New CHyperlink
    
    Dim iLoop As Integer
    'Loop through the LinkText and change
    'all spaces into chr(160).
    'Chr(160) looks like a space but it will
    'not wrap. ALWAYS keep the hyperlink text on
    'one line in the RTF box.
    For iLoop = 1 To Len(LinkText)
        If Mid$(LinkText, iLoop, 1) = " " Then
            Mid$(LinkText, iLoop) = Chr$(160)
        End If
    Next
    
    'set the properties passed into the method
    objNewMember.LinkText = LinkText
    objNewMember.LinkURL = LinkURL
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    'Change the selected text off the RichTextBox
    Dim lngOldColor As Long
    Dim blnUnderline As Boolean
    With RichTextBox
        'Save the selected colour and underline state
        lngOldColor = .SelColor
        blnUnderline = .SelUnderline
        'The link colour could be changed to
        'a property value.
        .SelColor = vbBlue
        .SelUnderline = True
        .SelText = LinkText
        'Restore the colour and underline state
        .SelColor = lngOldColor
        .SelUnderline = blnUnderline
        'Add a space after the hyperlink
        .SelText = " "
        .SetFocus
    End With
    'return the object created
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

Public Property Get Item(vntIndexKey As Variant) As CHyperlink
    'used when referencing an element in the collection
    'vntIndexKey contains either the Index or Key to the collection,
    'this is why it is declared as a Variant
    'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
    'used when retrieving the number of elements in the
    'collection. Syntax: Debug.Print x.Count
    Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
    'used when removing an element from the collection
    'vntIndexKey contains either the Index or Key, which is why
    'it is declared as a Variant
    'Syntax: x.Remove(xyz)
    mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
    'this property allows you to enumerate
    'this collection with the For...Each syntax
    Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
    'creates the collection when this class is created
    Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
    'destroys collection when this class is terminated
    Set mCol = Nothing
End Sub

Private Sub RichTextBox_Click()
    Dim strLine As String
    Dim lngLine As Long
    Dim lngLineIndex As Long
    Dim lngSelStart As Long
    Dim lngHWnd As Long
    Dim barrLine(MAXLINELENGTH - 1) As Byte
    Dim hlnLink As CHyperlink
    Dim i As Integer, iPos As Integer
    
    lngHWnd = RichTextBox.hwnd
    'save the caret position
    lngSelStart = RichTextBox.SelStart
    'Get the line number from the caret position
    lngLine = SendMessage(lngHWnd, EM_LINEFROMCHAR, lngSelStart, 0&)
    'get the poition of the first character on that line
    lngLineIndex = SendMessage(lngHWnd, EM_LINEINDEX, lngLine, 0&)
    'calculate the caret position on the "active" line
    lngSelStart = lngSelStart - lngLineIndex
    'save the MAXLINELENGTH in the first word of
    'the byte array
    barrLine(0) = MAXLINELENGTH And 255
    barrLine(1) = MAXLINELENGTH \ 256
    'get the line and save it in the byte array
    SendMessage lngHWnd, EM_GETLINE, lngLine, barrLine(0)
    'copy the byte array into a string
    For i = 0 To MAXLINELENGTH - 1
        If barrLine(i) = 0 Then
            Exit For
        End If
        strLine = strLine & Chr$(barrLine(i))
    Next
    
    'Loop through the collection and search
    'strLine for a hyperlink
    For Each hlnLink In mCol
        iPos = InStr(iPos + 1, strLine, hlnLink.LinkText, vbTextCompare)
        If iPos Then
            If lngSelStart >= iPos And lngSelStart <= iPos + Len(hlnLink.LinkText) Then
                'GOT IT!
                hlnLink.OpenLink
                Exit For
            End If
        End If
    Next
End Sub
