1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
| Function code(url)
Set req = CreateObject("microsoft.xmlhttp")
With req
.Open "get", url, False
.setRequestHeader "Accept", "text/html, application/xhtml+xml, */*"
.setRequestHeader "Accept-Language", "fr-FR"
.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.setRequestHeader "Host", "www.youtube.com"
.setRequestHeader "DNT", "1"
.setRequestHeader "Connection", "Keep - Alive"
.send
'Debug.Print .GetAllResponseHeaders
code = .responseText
End With
End Function
Sub test()
Dim tablocat(100, 2), tablochaine(600, 6)
With CreateObject("htmlfile")
'récupération de la listes des categories de chaines
.body.innerhtml = code("https://www.youtube.com/channels")
For Each elem In .all
If elem.classname = "category-title-link" Then
t = t + 1: tablocat(t, 0) = elem.innertext: tablocat(t, 1) = "https://www.youtube.com" & Replace(elem.href, "about:", "")
'Debug.Print elem.innertext & " link= https://www.youtube.com" & Replace(elem.href, "about:", "")
End If
Next
For i = 1 To 1 'j'ai arrêté a 1 les categorie tu dois remplacer par t pour toutes les categories mais c'est plus long
If tablocat(i, 0) <> "" Then
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = tablocat(i, 0)
'Debug.Print vbCrLf & "CATEGORIES de la chaine " & tablocat(i, 0) & vbCrLf
.body.innerhtml = code(tablocat(i, 1))
For Each elem In .all
If elem.classname = "yt-gb-shelf-hero-thumb" Then
c = c + 1
tablochaine(c, 0) = tablocat(i, 0)
tablochaine(c, 1) = elem.Title
tablochaine(c, 2) = "https://www.youtube.com" & Replace(elem.href, "about:", "")
tablochaine(c, 3) = a_propos("https://www.youtube.com" & Replace(elem.href, "about:", "") & "/about")(0)
tablochaine(c, 4) = a_propos("https://www.youtube.com" & Replace(elem.href, "about:", "") & "/about")(1)
'tablocat(i, 1) = tablocat(i, 1) & vbCrLf & elem.innertext: tablocat(t, 1) = "https://www.youtube.com" & Replace(elem.href, "about:", "")
'Debug.Print "titre: " & elem.Title & " link= https://www.youtube.com" & Replace(elem.href, "about:", "")
End If
Next
End If
Next
End With
'MsgBox tablochaine(3, 1) & vbCrLf & "titre : " & tablochaine(1, 2) & vbCrLf & " apropos : " & tablochaine(1, 4)
Cells(2, 1).Resize(c, 6) = tablochaine
End Sub
Function a_propos(url)
Dim p(2) As String
With CreateObject("htmlfile")
.body.innerhtml = code(url)
For Each elem In .all
If elem.tagname = "PRE" And p(0) = "" Then p(0) = elem.innertext
If elem.classname = "about-stat" And p(1) = "" Then p(1) = elem.innertext
Next
End With
a_propos = p
End Function |
