Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Visual Basic Новый топик    Ответить
 Неожиданная проблема с парсингом  [new]
maxim863
Member

Откуда:
Сообщений: 111
У меня есть прога , которая парсит сайт . Работает идеально (на windows 7) . Но после покупки нового компа (и установки windows 10) начались проблемы . Выскакивает ошибка Run-time error ‘-2146697211(800c0005)’ в строке
oHttp.Send
Причем ровно после того , как изменяется переменная S .
После этого скорость интернета падает до 0 и восстанавливается только спустя некоторое время . Bluetooth отключен . Понимаю что вопрос слегка не по теме , но может кто-нибудь сталкивался с такой проблемой ?
+

Sub Softочки()
Application.DisplayAlerts = False
Call mainмассивы
Application.DisplayAlerts = True
End Sub


Sub mainмассивы()
    Dim r As Range
    Dim iLoop As Long
    Dim book1 As Workbook
    Dim book2 As Workbook
    Dim Ssilka As String
    Dim A As Long
    Dim S As Long
    Dim t As Long
    Dim W
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    W = Array("прошлый", "допрошлый", "додопрошлый")
   
For S = 1 To 2
 Set book1 = Workbooks.Open("E:\Поиск решения\Усов 7\вспомогательные программы\3 сезона\" + W(S) + "\таблица.xlsm")
  For t = 1 To 98
    Set book2 = Workbooks.Open("E:\Поиск решения\Усов 7\вспомогательные программы\3 сезона\" + W(S) + "\" & t & ".xlsm")
   
     
        With book1.Worksheets("таблица").Range("AF34:AF53")
           iLoop = 0
             For Each r In .Rows
              
            If r.Value = 5 Then
                  iLoop = iLoop + 1
                  Ssilka = r.Offset(0, -30).Hyperlinks.Item(1).Address
                  book2.Worksheets("Лист" & iLoop).Activate
                  extractTable Ssilka, book2, iLoop
              End If
            Next r
        End With

  book2.Save
  book2.Close
   Next t
     book1.Close
 Next S
 
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  
   End Sub


Function extractTable(Ssilka As String, book2 As Workbook, iLoop As Long)
    Dim oDom As Object, oTable As Object, oRow As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim data()
    Dim vata()
    Dim tata()
    Dim oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range
    Dim odRange As Range
    
    ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.Send
    
    ' cleanup response
    sResponse = StrConv(oHttp.responseBody, vbUnicode)
    Set oHttp = Nothing
    
    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
    
    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
        sResponse = .Replace(sResponse, "")
    End With
    Set oRegEx = Nothing
    
    ' create Document from response
    Set oDom = CreateObject("htmlFile")
    oDom.Write sResponse
    DoEvents
    
    ' table with results, indexes starts with zero
    Set oTable = oDom.getelementsbytagname("table")(3)
    
    DoEvents
    
    iRows = oTable.Rows.Length
    iCols = oTable.Rows(1).Cells.Length
    
    ' first row and first column contain no intresting data
    ReDim data(1 To iRows - 1, 1 To iCols - 1)
    ReDim vata(1 To iRows - 1, 1 To iCols - 1)
    ReDim tata(1 To iRows - 1, 1 To iCols - 1)
    ' fill in data array
    For x = 1 To iRows - 1
        Set oRow = oTable.Rows(x)
        
        For y = 1 To iCols - 1
             If oRow.Cells(y).Children.Length > 0 Then
                data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
                    data(x, y) = Replace(data(x, y), "about:", "http://allscores.ru/soccer/")
                vata(x, y) = oRow.Cells(y).innerText
                
            End If

        Next y
    Next x
    
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
   
     Set oRange = book2.ActiveSheet.Cells(110, 2).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
    
    Set odRange = book2.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata
    
    
    Set odRange = Nothing
    
   
End Function

17 дек 18, 13:53    [21765908]     Ответить | Цитировать Сообщить модератору
 Re: Неожиданная проблема с парсингом  [new]
ldfanate
Member

Откуда:
Сообщений: 79
maxim863,

ну видимо после изменения S из другого файла подтягивается кривая ссылка на сайт. Или например на сайт который отдаёт кривой сертификат безопасности (ssl-авторизация), и новая винда (безопасность браузера) блокирует ссылку как подозрительную.

Посмотри в системном журнале windows, что там падает при возникновении такой ошибки.
Если https-ссылка, то возможно перед send присвоить oHtttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, "true"
19 дек 18, 16:26    [21768563]     Ответить | Цитировать Сообщить модератору
 Re: Неожиданная проблема с парсингом  [new]
maxim863
Member

Откуда:
Сообщений: 111
ldfanate,
Посмотрел в системном журнале windows : Security-SPP ; DistributedCOM (не совсем понял , что это значит )
Но затем я отключил Защитник Windows . Получил тот же результат .
Потом я зашел в старый ноут (windows 7) , включил прогу-все отлично запарсило , но параллельно на новом компе (Windows 10) опять отключился интернет , хотя на мобиле и старом компе он работал отлично .
Вывод : это точно делает Windows 10 , только не понятно что это делает и как это исправить/отключить ?
21 дек 18, 12:08    [21770352]     Ответить | Цитировать Сообщить модератору
Все форумы / Visual Basic Ответить