SQLRU.net
Разработка приложений баз данных

Начало » Программирование » Visual Basic » Проблема при парсинге сайта
Проблема при парсинге сайта [сообщение #2777] Sat, 15 July 2023 14:00 Переход к следующему сообщению
maxim532 в настоящее время не в онлайне  maxim532
Сообщений: 1
Зарегистрирован: July 2023
Junior Member
У меня есть программа, которая парсит сайт (забирает одну табличку).Программа работала хорошо, но после того как сайт переписали, перестала выдавать нужный результат.
До
/index.php/fa/159/0/
После
/index.php/fa/160/0/
Код
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 Ssilka As String
    Dim A As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set book1 = Workbooks.Open("D:\Super M\Поиск решения\Усов 9\Разработка\Шапка для болванки ФИН ПРОГИ\таблица.xlsm")
     
   
     
        With book1.Worksheets("таблица").Range("B34:B53")
           iLoop = 0
             For Each r In .Rows
              
            
                  iLoop = iLoop + 1
                  Ssilka = r.Hyperlinks.Item(1).Address
                  book1.Worksheets("Лист" & iLoop).Activate
                  extractTable Ssilka, book1, iLoop
              
            Next r
        End With
  
  book1.Save
  book1.Close
  
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  
   End Sub


Function extractTable(Ssilka As String, book1 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, "<SCRIPT language=JavaScript><!--"))
    
    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")(0)
    
    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 odRange = book1.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata
    
    
    Set odRange = Nothing
    
   
End Function
Ссылка на сайт:
https:// allscores.club/league.php?sport=soccer&champ=4804&f_ team=414
  • Вложение: До.png
    (Размер: 189.74KB, Загружено 490 раз)
  • Вложение: После.png
    (Размер: 197.29KB, Загружено 551 раз)
Re: Проблема при парсинге сайта [сообщение #2779 является ответом на сообщение #2777] Sun, 16 July 2023 11:40 Переход к предыдущему сообщениюПереход к следующему сообщению
BlackEric в настоящее время не в онлайне  BlackEric
Сообщений: 288
Зарегистрирован: June 2022
Senior Member
Смотрите в сторону кодировок
Re: Проблема при парсинге сайта [сообщение #4574 является ответом на сообщение #2777] Tue, 05 March 2024 17:58 Переход к предыдущему сообщению
DarkMaster в настоящее время не в онлайне  DarkMaster
Сообщений: 33
Зарегистрирован: August 2022
Member
Сайт начал возвращать данные в UTF-8. Просто перекодируйте текст.
Переход к форуму:
  


Текущее время: Wed Apr 17 07:54:38 GMT+3 2024

Общее время, затраченное на создание страницы: 0.00836 секунд