进入VB，选择“标准EXE”新建一工程，选择“工程”菜单下的“引用”，选中Microsoft
scripting Runtime”，然后再选择“工程”菜单中的“部件”，在弹出的对话框中选择“Microsoft common dialog control
6.0”，在工具箱中加入通用对话框控件。接下来在默认窗体FORM1上添加三个标签控件，一个文本框控件text1，一个列表框控件LIST1，并命名为lstemail，三个命令command1~command3,其Caption属性分别设置为“提取”、“整理”、“保存”，设置完成的界面如下图所示：
二 输入源程序
Dim X, Y, St1, St2, tmpY As Integer '提取EMAIL地址子程序 Private
Sub StripEmail(FilePath As String) Dim tmpEmail1, tmpEmail2 As String
Open FilePath For Input As #1 Do Until EOF(1) On Error
Resume Next Input #1, tmpEmail1 For X = 1 To Len(tmpEmail1)
tmpEmail2 = Mid(tmpEmail1, X, 7) '查找EMAIL标志 If tmpEmail2 =
"mailto:" Then St1 = X tmpY = X + 1 For Y = 1 To
Len(tmpEmail1) tmpEmail2 = Mid(tmpEmail1, tmpY, 1) If tmpEmail2 =
Chr(34) Or tmpEmail2 = "?" Then St2 = tmpY tmpEmail2 =
Mid(tmpEmail1, St1 + 7, ((St2 - St1) - 7)) If (Left(tmpEmail2, 2)
<> "//") And (Left(tmpEmail2, 1) <> " ") Then
lstEmail.AddItem tmpEmail2 Exit For End If End If tmpY
= tmpY + 1 Next Y End If Next X Loop Close #1 End
Sub Private Sub Command1_Click() Dim fs As New
FileSystemObject ' 建立 FileSystemObject Dim fd As Folder ' 定义 Folder 对象
Dim sfd As Folder Set fd = fs.GetFolder(Text1)
Command1.Enabled = False Screen.MousePointer = vbHourglass
FindFile fd, "*.htm" 'Text1.Text Command1.Enabled = True
Screen.MousePointer = vbDefault End Sub Sub FindFile(fd As
Folder, FileName As String) Dim sfd As Folder, f As File ' Part
I查找该文件夹的所有文件 For Each f In fd.Files If UCase(f.Name) Like
UCase(FileName) Then Label2 = f.Path StripEmail (f.Path)
lblEmail = "已查找到的地址数为: " & lstEmail.ListCount End If
DoEvents Next ' Part II循环查找所有子文件夹 For Each sfd In
fd.SubFolders FindFile sfd, FileName ' 循环查找 Next End Sub
Private Sub Command2_Click() '去掉重复的EMAIL地址 For i = 0 To
lstEmail.ListCount - 1 For X = 0 To lstEmail.ListCount - 1 If i =
X Then GoTo Nextx If LCase(lstEmail.List(X)) = LCase(lstEmail.List(i))
Then On Error Resume Next lstEmail.RemoveItem X End If
Nextx: Next X Next i lblEmail = "共有" &
lstEmail.ListCount & "个地址" End Sub '保存 Private Sub
Command3_Click() '设置文件名 Dim strname As String
commondialog1.Filter = "文本文件(*.txt)|*.txt" commondialog1.ShowSave
If commondialog1.FileName <> "" Then strname =
commondialog1.FileName Else strname = App.Path &
"\emailaddress.txt" End If '保存文件 Open strname For Output As #1
On Error Resume Next For i = 0 To lstEmail.ListCount - 1 Print
#1, lstEmail.List(i) Next Close #1 End Sub
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
