Info de Allocine

[bmhx60]

Bonjour a tous,

Est il possible de prendre des informations du site allociné par vba pour faire une base de donnée excel .

A partir du titre du film, on reccupere le Genre - Annee du film - Durée du film.

Merci a tous de votre aide
bonne journée.

 

[Gruick]

Re : Info de Allocine

Bonjour,

Peux-tu être moins bref et plus précis ?
L'adresse exacte du site, car il y en a beaucoup des allocinés.
Et puis si c'est un site "à tiroirs", c'est quasi impossible

On attend tes indications

Gruick

 

[Gruick]

Re : Info de Allocine

Bon,

Une question floue à 11h57

déconnecté à midi,

pas de signe de vie à 15 heures, la moindre des politesse serait de s'intéresser au sujet qu'on lance...

alors d..... toi

Gruick

 

[bmhx60]

Re : Info de Allocine

Bonjour Gruick,

Désolé mais je n’étais pas a mon bureau,
Donc si tu veux quand même m’aider le site est AlloCiné : Cinéma, Séries TV, Stars, Vidéos, DVD et VOD
Par exemple ou un autre site qui donne des informations sur les films.

Tout cela pour me permettre de gérer au mieux ma vidéothèque.

Merci encore.

 

[PMO2]

Re : Info de Allocine

Bonjour,

Une piste avec le code suivant à copier dans un module standard

''Library SHDocVw
''C:\WINDOWS\system32\ieframe.dll\1
''Microsoft Internet Controls

''Library MSHTML
''C:\WINDOWS\system32\MSHTML.TLB
''Microsoft HTML Object Library

Sub InfosAlloCine()
Dim IE As Object  'SHDocVw.InternetExplorer
Dim HTMLDoc As Object 'HTMLDocument
Dim S As Worksheet
Dim R As Range
Dim Url$
Dim A$
Dim T() As String
Dim var
Dim nbPage&
Dim cpt&
Dim i&
Dim j&
Dim bool As Boolean
Url$ = "http://www.allocine.fr/film/alaffiche.html?page="
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True    'pour masquer Internet Explorer mettez False à la place de True
IE.Navigate Url$ & 2
Do Until IE.ReadyState = 4
  DoEvents
Loop
IE.Silent = False
Set HTMLDoc = IE.Document
A$ = HTMLDoc.documentElement.innerText
A$ = Mid(A$, InStr(1, A$, "Alphabétique") + Len("Alphabétique"), 30)
A$ = Mid(A$, InStr(1, A$, "/") + 1)
nbPage& = CLng(Trim(Mid(A$, 1, InStr(1, A$, ">") - 1)))
Set HTMLDoc = Nothing
With Application
  bool = .DisplayStatusBar
  .DisplayStatusBar = True
End With
  '///////////////////////////////////////////////////////////
  '/// J'ai limité à 10 pages pour le test
  '/// Pour les avoir toutes, mettre nbPage& à la place de 10)
For i& = 1 To 10 'nbPage&
  '///////////////////////////////////////////////////////////
  Application.StatusBar = "Traitement de la page " & i& & "/" & nbPage& & " du site Allocine"
  With IE
    .Navigate Url$ & i&
    Do Until .ReadyState = 4
      DoEvents
    Loop
    Set HTMLDoc = .Document
    A$ = HTMLDoc.documentElement.innerText
    A$ = Mid(A$, InStr(1, A$, "résultats") + Len("résultats"))
    A$ = Mid(A$, 1, InStr(1, A$, "<<") - 2)
    var = Split(A$, vbCrLf)
    cpt& = cpt& + 1
    ReDim Preserve T(1 To 7, 1 To cpt&)
    For j& = 0 To UBound(var)
      If T(1, cpt&) = "" Then
        T(1, cpt&) = Trim(var(j&))
      ElseIf Left(var(j&), 16) = "Ajouter et noter" Then
        A$ = Trim(var(j&))
        A$ = Trim(Mid(A$, Len("Ajouter et noter") + 1))
        T(2, cpt&) = Trim(Mid(A$, 1, InStr(1, A$, "(") - 1))
        A$ = Trim(Mid(A$, InStr(1, A$, "(") + 1))
        T(3, cpt&) = Trim(Mid(A$, 1, InStr(1, A$, ")") - 1))
        A$ = Trim(Mid(A$, InStr(1, A$, ")") + 1))
        T(4, cpt&) = Trim(Mid(A$, InStr(1, A$, ":") + 1))
      ElseIf Left(var(j&), 3) = "De " Then
        T(5, cpt&) = Trim(Mid(var(j&), 3))
      ElseIf Left(var(j&), 5) = "Avec " Then
        If T(6, cpt&) = "" Then
          T(6, cpt&) = Trim(Mid(var(j&), 5))
        Else
          T(6, cpt&) = T(6, cpt&) & " " & Trim(Mid(var(j&), 5))
        End If
      On Error Resume Next
      ElseIf Left(var(j& + 1), 13) = "Voir la bande" Then
        If Err = 0 Then
          T(7, cpt&) = Trim(var(j&))
        Else
          Err.Clear
          On Error GoTo 0
        End If
      ElseIf Left(var(j&), 13) = "Voir la bande" Then
        cpt& = cpt& + 1
        ReDim Preserve T(1 To 7, 1 To cpt&)
      End If
    Next j&
  End With
  Beep
Next i&
Set HTMLDoc = Nothing
IE.Quit
Set IE = Nothing
With Application
  .StatusBar = False
  .DisplayStatusBar = bool
End With
Set S = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
With S.Cells
  With .Font
    .Name = "Tahoma"
    .Size = 8
  End With
  .HorizontalAlignment = xlLeft
  .EntireColumn.AutoFit
End With
End Sub

Cordialement.

PMO
Patrick Morange