VB开发——如何快速地从网页中获得Email地址

如何快速地从网页中获得Email地址
欧金成   朱治国   林德杰  
（广东工业大学自动化学院）
 摘要  对于一个网上销售商，如何获得客户的Email地址，是销售自己产品必不可少的途径。本文笔者通过程序实现了Email地址自动获得的方法，从而避免了枯燥无味的手工查找。
关键词 VB   转换控件   文本控件
1       引言
在当今竞争激烈的社会环境下，一个企业如想处于不败之地，尤其是对于从事销售方面的企业，如何快速地寻找符合自己产品的客户及联系的方式是非常必要的。本文就是根据某个销售商的要求，为了避免员工枯燥无味的手工查找对方Email地址，并且又费时又费力，提出了一种自动获得Email地址的想法，达到既省时又省力的效果，笔者根据该要求设计了一个软件达到了此目的。该软件是用Visual Basic编写的。
2  程序实现
在程序编写之前，员工必须知道符合自己产品的客户的具体网址，这一点有许多种方法可以做到，其中比较有名的是利用Google搜索引擎（http://www.google.com）,这里假设要获得Email的网址是“http://www.durham-duplex.co.uk/contact.html”。具体程序编写如下：
1）打开VB建立一个新工程（工程1）及一个新窗体（Form1），同时添加“Microsoft Internet Transfer Control 6.0”（Inet1）[利用该控件的OpenURL方法获取HTML源码]和“Microsoft Rich Textbox Control 6.0(SP4)”（RichTextBox1，RichTextBox2）[介绍该控件的文章很多，笔者使用RichTextBox1存放HTML源码，RichTextBox2存放获取的EMail结果。]两个VB自带部件。
2）窗体Form1上手工加入控件RichTextBox1，RichTextBox2，Inet1，Command1（CommandButton控件），Command2。
3）写EMAIL的截取方法，程序代码如下：
Private Sub EMail_Rich(Rich1 As RichTextBox, Rich2 As RichTextBox)
'以下是定义变量，整型变量因为考虑到Email长度会超出Integer型的65535界限，所以使用Long型
     Dim EmailStr As String  '存放取得的Email地址
     Dim Str_Temp1 As String  '存放取得的“@”前面的某个字符
     Dim Str_Temp2 As String  '存放取得的“@”后面的某个字符
     Dim Where_Str  As Long  '存放“@”所在的位置
     Dim Where_Str1 As Long  '存放“@”前截取字符所在位置
     Dim Where_Str2 As Long  '存放“@”后截取字符所在位置
     Dim Start_Number As Long   '存放该EMAIL的长度
     Dim Start_Number1 As Long  '存放该EMAIL的“@”前的字符数
     Dim Start_Number2 As Long  '存放该EMAIL的“@”后的字符数
     Dim Start_No As Long  '存放开始查找“@”的起始位置
     Dim Logic_1 As Boolean  '存放判断“@”前面字符的条件准则
     Dim Logic_2 As Boolean  '存放判断“@”后面字符的条件准则
         
     '给变量赋初值
     EmailStr = ""
     Str_Temp1 = ""
     Str_Temp2 = ""
     Where_Str = 0
     Where_Str1 = 0
     Where_Str2 = 0
     Start_Number = 0
     Start_Number1 = 0
     Start_Number2 = 0
     Start_No = 1  '一开始当然从第一位开始搜索
     Logic_1 = False
     Logic_2 = False
         
     '控件初始化
     Rich2.Text = ""  '先清空控件Rich2中的Text值
         
     '程序开始
     Do While 1 = 1  '给一个永远真值的循环，该循环控制整个HTML页
       Where_Str = Rich1.Find("@", Start_No)  '开始查找第一个“@”位置
           
       If Where_Str <= 0 Then  '该值小于等于0代表没有找到
          Exit Do  '满足了以上条件，说明所有查找结束，退出循环
       End If
           
       Where_Str1 = Where_Str  '把“@”的位置赋给Where_Str1
       Where_Str2 = Where_Str  '把“@”的位置赋给Where_Str2

       Do While 1 = 1 '给一个永远真值的循环，该循环控制一个EMAIL中“@”前面内容
         Where_Str1 = Where_Str1 - 1  '逐个对“@”前内容进行比较，该变量控制位置
         Rich1.SelStart = Where_Str1  '设置控件Rich1中选择字符串的起始位置
         Rich1.SelLength = 1  '设置Rich1中选择字符串的长度,因为是单个比较,所以赋“1”
         Str_Temp1 = Rich1.SelText  '取得该字符
         '根据ASCII码表设置EMAIL字符串的规则，从而取得EMAIL地址，因为太长，所以分断写
         Logic_1 = (Asc(Str_Temp1) > 44 And Asc(Str_Temp1) < 47)
         Logic_1 = Logic_1 Or (Asc(Str_Temp1) > 47 And Asc(Str_Temp1) < 57)
         Logic_1 = Logic_1 Or (Asc(Str_Temp1) > 63 And Asc(Str_Temp1) < 91)
         Logic_1 = Logic_1 Or (Asc(Str_Temp1) > 96 And Asc(Str_Temp1) < 123)
         If Logic_1 = False Then '如果该字符不规则，说明已经不是Email地址的内容
           Exit Do  '满足了以上条件，退出循环
         End If
         Start_Number1 = Start_Number1 + 1 '说明符合规则，需要继续查看下一个字符
       Loop
           
       Do While 1 = 1  '该循环与前一个判断“@”前的字符意思相同，不再加入注释
         Where_Str2 = Where_Str2 + 1
         Rich1.SelStart = Where_Str2
         Rich1.SelLength = 1
         Str_Temp2 = Rich1.SelText
         Logic_2 = (Asc(Str_Temp2) > 44 And Asc(Str_Temp2) < 47)
         Logic_2 = Logic_2 Or (Asc(Str_Temp2) > 47 And Asc(Str_Temp2) < 57)
         Logic_2 = Logic_2 Or (Asc(Str_Temp2) > 63 And Asc(Str_Temp2) < 91)
         Logic_2 = Logic_2 Or (Asc(Str_Temp2) > 96 And Asc(Str_Temp2) < 123)
         If Logic_2 = False Then
           Exit Do
         End If
         Start_Number2 = Start_Number2 + 1
       Loop
       'EMAIL的总长度就是“@”前、后符合规则的字符的长度加上“@”的长度
       Start_Number = Start_Number1 + Start_Number2 + 1
           
       Rich1.SelStart = Where_Str1 + 1  '该EMAIL起始位置，正好是“@”前面字符最终位置
       Rich1.SelLength = Start_Number  '该EMAIL的总长度
       EmailStr = Rich1.SelText
       Rich2.Text = Rich2.Text & Chr(10) & EmailStr  '获得该EMAIL
       Start_No = Where_Str + Start_Number2  '继续定义下一重循环要查找“@”的起始位置
           
       '重新初始化一些中间变量
       EmailStr = ""
       Str_Temp1 = ""
       Str_Temp2 = ""
       Start_Number = 0
       Start_Number1 = 0
       Start_Number2 = 0
    Loop
End Sub
4）再添加如下程序代码来控制程序执行：
Private Sub Command1_Click()
   EMail_Rich RichTextBox1, RichTextBox2  '使用3中的方法
 End Sub
        
 Private Sub Command2_Click()
    End  '终止程序
 End Sub
        
Private Sub Form_Load()
 '初始化控件
  Command1.Caption = "截取"
  Command2.Caption = "退出"
  '获取网页中的HTML代码，并放到RichTextBox1中
RichTextBox1.Text = Inet1.OpenURL("http://www.durham-duplex.co.uk/contact.html";)
End Sub
3  结束语
以上程序已在VB6.0企业版中通过。通过上面的例子，笔者希望有“抛砖引玉”的功效，让读者在工作中遇到类似问题时得到一些启发。