Question

我有以下代码，它非常适合从一个网站检索电子邮件，但我希望它适用于多个网站。基本上它搜索网站的@字符源代码并将其粘贴到工作表的一个范围内。我想知道无论如何我都可以从列表的所有网站上获取这些内容，并将它们放在另一张下面。

Private Sub Email_Extractor_From_Website()
Dim oWebData As Object, sPageHTML  As String, sWebURL As String

'The code works fine for 1 website of the below, however i'd like it to work for several websites
 sWebURL = "http://www.example1.com/"
 sWebURL = "http://www.example2.com/"
 sWebURL = "http://www.example3.com./"
'etc
'Extract data from website to Excel using VBA
 Set oWebData = CreateObject("MSXML2.ServerXMLHTTP")
 oWebData.Open "GET", sWebURL, False
 oWebData.send
 sPageHTML = oWebData.responseText

'Get webpage data into Excel
 Extract_Email_Address_From_Text sPageHTML End Sub

   Private Sub Extract_Email_Address_From_Text(Optional Text_Content As String)
Dlim_List = " ""(),:;<>@[\]"

'Get Text Content and assign to a Variable
If Text_Content = "" Then
    Text_Content = ThisWorkbook.Sheets(1).Cells(2, 1)
End If
Web_Page_Text1 = Text_Content
If Web_Page_Text1 = "" Then
    MsgBox "Error: No Input Provided - Provide Input"
    Exit Sub
End If

'Scan each word in Text and Extract Email Addresses
ORow = 2
While (Web_Page_Text1 <> "")

    'Locate position of symbol "@"
    First_@ = VBA.InStr(1, Web_Page_Text1, "@", vbTextCompare)

    'If there is no occurance of "@" then terminate process
    If First_@ = 0 Then GoTo End_sub:

    'Seperate
    Web_Page_Text2 = VBA.Mid(Web_Page_Text1, 1, First_@ - 1)
    Web_Page_Text3 = VBA.Mid(Web_Page_Text1, First_@ + 1)
    Dlim_Pos_Max = 99999
    Dlim_Pos_Min = 0

    For i = 1 To VBA.Len(Dlim_List)
        Dlim_2_Compare = VBA.Mid(Dlim_List, i, 1)

        Dlim_Pos = VBA.InStrRev(Web_Page_Text2, Dlim_2_Compare, -1, vbTextCompare)
        If (Dlim_Pos > Dlim_Pos_Min) And (Dlim_Pos > 0) Then Dlim_Pos_Min = Dlim_Pos

        Dlim_Pos = VBA.InStr(1, Web_Page_Text3, Dlim_2_Compare, vbTextCompare)
        If (Dlim_Pos < Dlim_Pos_Max) And (Dlim_Pos > 0) Then Dlim_Pos_Max = Dlim_Pos
    Next i
    If Dlim_Pos_Max = 0 Then GoTo End_sub:

    'get Email list to Text Variable
    Email_Domain_Part = VBA.Mid(Web_Page_Text3, 1, Dlim_Pos_Max - 1)
    Email_Local_Part = VBA.Mid(Web_Page_Text2, Dlim_Pos_Min + 1, VBA.Len(Web_Page_Text2) - Dlim_Pos_Min)
    Mail_Address = Email_Local_Part & "@" & Email_Domain_Part

    'Scan through remaining content
    ORow = ORow + 1
    ThisWorkbook.Sheets(1).Cells(ORow, 2).Select
    ThisWorkbook.Sheets(1).Cells(ORow, 2) = Mail_Address
    Web_Page_Text1 = VBA.Mid(Web_Page_Text1, Dlim_Pos_Max + First_@ + 1)
Wend
 End_sub:
MsgBox " Process Completed" End Sub

Answer 1

尝试以下代码并稍加修改。如果有效，则更改以下函数名称：

Sub Test()
 Email_Extractor_From_Website "www.yahoo.com", 2
 Email_Extractor_From_Website "www.yahoo.com", 3
End Sub

Private Sub Email_Extractor_From_Website(sWebURL As String, OCol As Integer)
Dim oWebData As Object, sPageHTML  As String

'The code works fine for 1 website of the below, however i'd like it to work for several websites
'etc
'Extract data from website to Excel using VBA
 Set oWebData = CreateObject("MSXML2.ServerXMLHTTP")
 oWebData.Open "GET", sWebURL, False
 oWebData.send
 sPageHTML = oWebData.responseText

'Get webpage data into Excel
 Extract_Email_Address_From_Text sPageHTML, OCol
End Sub


Private Sub Extract_Email_Address_From_Text(Text_Content As String, OCol As Integer)
Dlim_List = " ""(),:;<>@[\]"

'Get Text Content and assign to a Variable
If Text_Content = "" Then
   Text_Content = ThisWorkbook.Sheets(1).Cells(2, 1)
End If
Web_Page_Text1 = Text_Content
If Web_Page_Text1 = "" Then
   MsgBox "Error: No Input Provided - Provide Input"
  Exit Sub
End If

'Scan each word in Text and Extract Email Addresses
ORow = 2
While (Web_Page_Text1 <> "")

'Locate position of symbol "@"
First_@ = VBA.InStr(1, Web_Page_Text1, "@", vbTextCompare)

'If there is no occurance of "@" then terminate process
If First_@ = 0 Then GoTo End_sub:

'Seperate
Web_Page_Text2 = VBA.Mid(Web_Page_Text1, 1, First_@ - 1)
Web_Page_Text3 = VBA.Mid(Web_Page_Text1, First_@ + 1)
Dlim_Pos_Max = 99999
Dlim_Pos_Min = 0

For i = 1 To VBA.Len(Dlim_List)
    Dlim_2_Compare = VBA.Mid(Dlim_List, i, 1)

    Dlim_Pos = VBA.InStrRev(Web_Page_Text2, Dlim_2_Compare, -1, vbTextCompare)
    If (Dlim_Pos > Dlim_Pos_Min) And (Dlim_Pos > 0) Then Dlim_Pos_Min = Dlim_Pos

    Dlim_Pos = VBA.InStr(1, Web_Page_Text3, Dlim_2_Compare, vbTextCompare)
    If (Dlim_Pos < Dlim_Pos_Max) And (Dlim_Pos > 0) Then Dlim_Pos_Max = Dlim_Pos
Next i
If Dlim_Pos_Max = 0 Then GoTo End_sub:

'get Email list to Text Variable
Email_Domain_Part = VBA.Mid(Web_Page_Text3, 1, Dlim_Pos_Max - 1)
Email_Local_Part = VBA.Mid(Web_Page_Text2, Dlim_Pos_Min + 1, VBA.Len(Web_Page_Text2) - Dlim_Pos_Min)
Mail_Address = Email_Local_Part & "@" & Email_Domain_Part

'Scan through remaining content
ORow = ORow + 1
ThisWorkbook.Sheets(1).Cells(ORow, OCol).Select
ThisWorkbook.Sheets(1).Cells(ORow, OCol) = Mail_Address
Web_Page_Text1 = VBA.Mid(Web_Page_Text1, Dlim_Pos_Max + First_@ + 1)
Wend
End_sub:
MsgBox " Process Completed"

End Sub

从多个网站提取电子邮件

1 个答案: