Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Makro do pobierania danych ze źródła strony WWW

fafas · Forumowicz Posty: 14

Działa bezbłędnie dzięki wielkie

fafas · Forumowicz Posty: 14

cwirek · Forumowicz Posty: 22

Niestety po przejściu na Office 365 kod przestał pracować. Nie pobiera tych zmiennych:
data-ec-name, data-ec-brand, data-ec-d2, data-ec-d1, data-ec-id, link, ex

Jakieś pomysły jak to naprawić? Dla przypomnienia kod wygląda tak:

Kod:

Sub BeatPort()
Set HTMLDoc = CreateObject("HTMLfile")
Set XMLObj = CreateObject("WinHttp.WinHttpRequest.5.1")
Set HTMLDocCat = CreateObject("HTMLfile")

'czyścimy arkusz
Sheets("Makro").Select
ActiveSheet.UsedRange.Clear

'zmienna określająca, ile stron chcemy przeszukać
Dim page_number As Integer 'podajemy liczbe stron
page_number = InputBox("Podaj liczbę stron od 1 do 60")

'wiersz, od którego zaczynamy dopisywać
r = 2

'podajemy atrybuty elementu "LI" ze strony (wiersza z albumem), które chcemy pobrać
'listę można modyfikować: dodawać i usuwać elementy oraz zmieniać ich kolejność
atrybuty = Array("data-ec-name", "data-ec-brand", "data-ec-d2", "data-ec-d1", "data-ec-id")
'wstawiamy wiersz nagłówka z nazwami atrybutów
Range("a1").Resize(1, UBound(atrybuty) + 1) = atrybuty
'dodajemy dwie osobne kolumny dla okładki i "ekskluzywa", które pobierane są w inny sposób (szczegóły niżej)
Range("a1").Offset(0, UBound(atrybuty) + 1).Resize(1, 7) = Array("link", "ex", "Data", "Artist", "id", "catnr", "data-ec-d3")

Dim UrlfName As String 'ustawiamy date poczatkowa
UrlfName = InputBox("Wprowadź date poczatkowa np. 2017-12-01")
Dim UrllName As String 'ustawiamy date koncowa
UrllName = InputBox("Wprowadź date koncowa np. 2017-12-01")

'przechodzimy przez wybrany zakres numerów
For i = 1 To page_number
'ustawiamy adres z kolejną liczbą

sURL = "https://www.beatport.com/releases/all?preorders=mixed&start-date=" & UrlfName & "&end-date=" & UrllName & "&page=" & i

'wysyłamy żądanie do serwera
XMLObj.Open "GET", sURL, False
XMLObj.setRequestHeader "Cookie", "preorders=mixed"
XMLObj.Send

'przerzucamy odpowiedź do obiektu HTML dla łatwiejszego poruszania się po pobranej stronie
HTMLDoc.body.innerhtml = XMLObj.responseText

'wyszukujemy listy na stronie
Set ul = HTMLDoc.getElementsByTagName("ul")

'przeszukujemy te listy w poszukiwaniu tej z właściwą klasą
For Each ul In HTMLDoc.getElementsByTagName("ul")
'sprawdzamy klasę
If ul.classname = "bucket-items ec-bucket filter-page-releases-list" Then
'pobieramy kolejne wiersze listy
For Each li In ul.getElementsByTagName("li")
'wyłączamy obsługę błędów na potrzeby preorderów i exów (nie zawsze występują)
On Error Resume Next
'pobieramy wcześniej zdefiniowane atrybuty do kolejnych komórek
For atr = 0 To UBound(atrybuty)
Cells(r, atr + 1) = li.Attributes(atrybuty(atr)).Value
Next

'link do okładki i exy pobieramy nie z atrybutów całego wiersza, ale z elementów podrzędnych
With li.Children(0).Children(0)
'link z obrazka
Cells(r, atr + 1) = .Children(0).Attributes("data-src").Value
'ex z elementu sąsiadującego z obrazkiem
Cells(r, atr + 2) = .Children(1).innerText

End With
Cells(r, atr + 3) = li.Children(1).Children(0).Children(3).innerText
Cells(r, atr + 4) = li.Children(1).Children(0).Children(1).innerText
Cells(r, atr + 5) = Replace(li.Children(0).Children(0).href, "about:", "")

lnk = "https://www.beatport.com" & Replace(li.Children(0).Children(0).href, "about:", "")

XMLObj.Open "GET", lnk, False
XMLObj.Send

HTMLDocCat.body.innerhtml = XMLObj.responseText

Set cat = HTMLDocCat.getElementById("pjax-target").getElementsByTagName("ul")(0)
Cells(r, atr + 6).Value = cat.Children(2).Children(1).innerText
Set cat = HTMLDocCat.getElementById("pjax-target").getElementsByTagName("ul")(2)
Cells(r, atr + 7).Value = cat.Children(0).Children(2).Children(3).innerText

'przywracamy obsługę błędów
On Error GoTo 0

'zwiększamy numer wiersza
r = r + 1
Next
'wychodzimy z pętli wewnętrznej, w której szukaliśmy klasy
'ponieważ właściwy element został znaleziony
Exit For
End If
Next

'wrzucamy informację o postępie do paska stanu
Application.StatusBar = "Zaciągniętych stron: " & i & " z " & page_number
Next

'resetujemy pasek stanu
Application.StatusBar = ""