excel - Vba catches emails from list of websites now showing Error

Question

original code from : " E-mail extracting from several websites " answer by "Balasubramaniyan Ramadoss"

It is stucking on a line (oWebData.Open "GET", sWebURL, False) shows:

runtime error '-2147012890 (80072ee6)':

System error: -2147012890.

Can someone please update this to work on office 2016 64 bit, and tell me the reference to add also if needed

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

Answer 1

等待大神答复