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
lstResults.Clear
Screen.MousePointer = vbHourglass
DoEvents
' 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, _
num_files
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), _
vbNormal)
Do While Len(file_name) > 0
' Process the file.
ProcessFile dir_name & file_name, excluded, _
num_files
' Get the next file.
file_name = Dir$()
Loop
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 _
Then
' 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)
Loop
' Process the subdirectories.
For i = 1 To num_subdirs
ProcessDirectory subdirs(i), file_types, excluded, _
num_files
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 - _
7)
' 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, _
new_address)
End If
pos = InStr(pos2, file_contents, "mailto:")
Loop
' 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
Refresh
End If
End Sub
|