What's New
Q & A
Tip Jar
C# Helper...
Follow VBHelper on Twitter
MSDN Visual Basic Community
TitleModify mailto links to reduce spam
Keywordsspam, mailto, mail, email, link
CategoriesUtilities, Strings, Internet
This program searches a directory hierarchy for files of certain types such as *.htm and *.xml. For each file, it searches for mailto links. You can list email domains that it should ignore in this search.

When it finds a matching file, it replaces the mailto email addresses with addresses that are harder for spambots to read. For example, it converts "me@somewhere.com" to "me AT somewhere.com". Visitors who click the link will need to replace the " AT " with "@" in their mail application.

The cmdSearch_Click event handler calls subroutine ProcessDirectory to process the selected directory. ProcessDirectory searches a directory for files that match specified patterns and calls ProcessFile to process them. It then searches the directory for subdirectories and recursively calls itself to process them.

Private Sub cmdSearch_Click()
Dim file_types As Variant
Dim file_type As Integer
Dim excluded As Variant
Dim num_files As Long
Dim i As Integer

    lstResults.Visible = False
    Screen.MousePointer = vbHourglass

    ' Get the list of domains to exclude.
    excluded = Split(txtExclude.Text, vbCrLf)
    For i = LBound(excluded) To UBound(excluded)
        excluded(i) = Trim$(excluded(i))
    Next i

    ' Get the list of file types to examine.
    file_types = Split(txtFileTypes.Text, vbCrLf)
    For i = LBound(file_types) To UBound(file_types)
        file_types(i) = Trim$(file_types(i))
    Next i

    ' Search the directory.
    m_DirName = txtDirectory.Text
    If Right$(m_DirName, 1) <> "\" Then m_DirName = _
        m_DirName & "\"

    ProcessDirectory m_DirName, file_types, excluded, _

    lstResults.Visible = True
    Screen.MousePointer = vbDefault
End Sub

' Search this directory for matching files.
Private Sub ProcessDirectory(ByVal dir_name As String, _
    ByVal file_types As Variant, ByVal excluded As Variant, _
    ByRef num_files As Long)
Dim i As Integer
Dim file_name As String
Dim subdirs() As String
Dim num_subdirs As Long

    ' Process files in this directory.
    ' Try for each file type.
    For i = LBound(file_types) To UBound(file_types)
        If Len(file_types(i)) > 0 Then
            file_name = Dir$(dir_name & file_types(i), _
            Do While Len(file_name) > 0
                ' Process the file.
                ProcessFile dir_name & file_name, excluded, _

                ' Get the next file.
                file_name = Dir$()
        End If
    Next i

    ' Get the subdirectories.
    file_name = Dir$(dir_name, vbDirectory)
    Do While Len(file_name) > 0
        ' Make sure it's a directory.
        If GetAttr(dir_name & file_name) And vbDirectory _
            ' Skip . and ..
            If file_name <> "." And file_name <> ".." Then
                ' Save this directory.
                num_subdirs = num_subdirs + 1
                ReDim Preserve subdirs(1 To num_subdirs)
                subdirs(num_subdirs) = dir_name & file_name _
                    & "\"
            End If
        End If

        ' Get the next subdirectory.
        file_name = Dir$(, vbDirectory)

    ' Process the subdirectories.
    For i = 1 To num_subdirs
        ProcessDirectory subdirs(i), file_types, excluded, _
    Next i
End Sub

' Process this file.
Private Sub ProcessFile(ByVal file_name As String, ByVal _
    excluded As Variant, ByRef num_files As Long)
Dim fnum As Integer
Dim file_contents As String
Dim pos As Long
Dim pos2 As Long
Dim is_excluded As Boolean
Dim address As String
Dim new_address As String
Dim i As Integer
Dim file_modified As Boolean

    file_modified = False

    ' Get the file's contents.
    fnum = FreeFile
    Open file_name For Input As #fnum
    file_contents = Input$(LOF(fnum), #fnum)
    Close #fnum

    ' See if the file contains "mailto:"
    pos = InStr(file_contents, "mailto:")
    Do While pos > 0
        ' Read to the next >.
        pos2 = InStr(pos + 7, file_contents, ">")
        address = Mid$(file_contents, pos + 7, pos2 - pos - _

        ' See if this is an excluded domain.
        is_excluded = False
        For i = LBound(excluded) To UBound(excluded)
            If Len(excluded(i)) > 0 Then
                If InStr(address, excluded(i)) Then
                    is_excluded = True
                    Exit For
                End If
            End If
        Next i

        If Not is_excluded Then
            ' Fix this occurrence.
            file_modified = True
            new_address = Replace(address, "@", " AT ")
            file_contents = Replace(file_contents, address, _
        End If

        pos = InStr(pos2, file_contents, "mailto:")

    ' See if we modified the file.
    If file_modified Then
        ' Rewrite the file.
        Open file_name For Output As #fnum
        Print #fnum, file_contents;
        Close #fnum

        ' Report this file.
        lstResults.AddItem file_name
        num_files = num_files + 1
        Caption = num_files
    End If
End Sub
Copyright © 1997-2010 Rocky Mountain Computer Consulting, Inc.   All rights reserved.