E-Mail Extrahieren von mehreren Websites

Question

Ich habe den folgenden Code, es funktioniert hervorragend zum Abrufen von E-Mails von nur einer Website, aber ich möchte es für mehrere Websites arbeiten. Im Grunde sucht es im Quellcode der Website nach dem Zeichen @ und fügt es in einen Bereich des Blattes ein. Ich würde gerne wissen, ob es überhaupt möglich ist, dass ich diese von allen Websites einer Liste abrufen und sie untereinander auf dem Blatt platzieren kann.

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

Versuchen Sie den Code unten und wenig verändert. Wenn es funktioniert, dann ändern Sie den folgenden Funktionsnamen:

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