Soyez le premier à donner votre avis sur cette source.
Vue 4 713 fois - Téléchargée 379 fois
' Déclaration des constantes liées aux API utilisées pour le téléchargement. Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0 Private Const INTERNET_FLAG_RELOAD = &H80000000 Private Const HTTP_QUERY_CONTENT_LENGTH = 5 Private Const HTTP_QUERY_STATUS_CODE = 19 ' Déclaration des API utilisées pour le téléchargement. Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, ByRef lpvBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As Boolean Public Type Infosradio Artist1 As String Album1 As String Titre1 As String Date1 As String Editeur1 As String Achat1 As String Image1 As String Artist2 As String Album2 As String Titre2 As String Date2 As String Editeur2 As String Achat2 As String Image2 As String Artist3 As String Album3 As String Titre3 As String Date3 As String Editeur3 As String Achat3 As String Image3 As String Artist4 As String Album4 As String Titre4 As String Date4 As String Editeur4 As String Achat4 As String Image4 As String Artist5 As String Album5 As String Titre5 As String Date5 As String Editeur5 As String Achat5 As String Image5 As String Reussi As Boolean End Type Public Function OuiFm() As Infosradio OuiFm = Yacast("http://cache.yacast.fr/V4/lemouv/d_data.html") End Function Private Function Yacast(Url As String) As Infosradio Dim Text As String Dim Infos On Error GoTo Erreur: Yacast.Reussi = False 'telecharge le fichier ou l'adresse du fichier info est stocké If TéléchargeFichier(Url, App.Path & "\info.txt") = False Then Exit Function End If Text = "" Text = OuvreFichier(App.Path & "\info.txt") 'Ouvre le fichier telechargé Text = Replace(Text, Chr(34), "") 'supprime les guillemet"" Text = Replace(Text, vbLf, "") 'suprime les retour a la ligne Text = Replace(Text, "<html><head><meta http-equiv=Content-Type content=text/html; charset=windows-1252><meta http-equiv=Expires content=0><meta http-equiv=Pragma content=no-cache><meta http-equiv=Cache-Control content=no-cache> <meta http-equiv=Refresh content=10; url=", "") 'supprime le debut du fichier => l'adresse Text = Replace(Text, "><base target=_self></head></html>", "") 'supprime la fin du fichier Url = Replace(Url, "/d_data.html", "/" & Text) 'crée l'adresse du fichier ou les info sont sotcké Kill (App.Path & "\info.txt") 'telecharge le fichier "info" If TéléchargeFichier(Url, App.Path & "\info.txt") = False Then Exit Function End If Text = "" Text = OuvreFichier(App.Path & "\info.txt") 'Ouvre le fichier telechargé If Text = "" Then Kill (App.Path & "\info.txt") Exit Function End If Text = Replace(Text, Chr(34), "") Text = Replace(Text, vbLf, "") Infos = Split(Text, ";") With Yacast .Titre1 = Replace(Infos(30), "top.titresPochettes[0] = ", "") .Album1 = Replace(Infos(31), "top.albumsPochettes[0] = ", "") .Artist1 = Replace(Infos(32), "top.interpretesPochettes[0] = ", "") .Achat1 = Replace(Infos(34), "top.urlsAchatPochettes[0] = ", "") .Date1 = Replace(Infos(38), "top.sortiePochettes[0] = ", "") .Editeur1 = Replace(Infos(39), "top.labelPochettes[0] = ", "") .Image1 = "http://cache.yacast.fr" & Replace(Infos(16), " top.imagesPochettesSrc[0] = ", "") .Titre2 = Replace(Infos(56), "top.titresPochettes[2] = ", "") .Album2 = Replace(Infos(57), "top.albumsPochettes[2] = ", "") .Artist2 = Replace(Infos(58), "top.interpretesPochettes[2] = ", "") .Date2 = Replace(Infos(64), "top.sortiePochettes[2] = ", "") .Editeur2 = Replace(Infos(65), "top.labelPochettes[2] = ", "") .Image2 = "http://cache.yacast.fr" & Replace(Infos(20), " top.imagesPochettesSrc[2] = ", "") .Titre3 = Replace(Infos(69), "top.titresPochettes[3] = ", "") .Album3 = Replace(Infos(70), "top.albumsPochettes[3] = ", "") .Artist3 = Replace(Infos(71), "top.interpretesPochettes[3] = ", "") .Date3 = Replace(Infos(77), "top.sortiePochettes[3] = ", "") .Editeur3 = Replace(Infos(78), "top.labelPochettes[3] = ", "") .Image3 = "http://cache.yacast.fr" & Replace(Infos(22), " top.imagesPochettesSrc[3] = ", "") .Titre4 = Replace(Infos(82), "top.titresPochettes[4] = ", "") .Album4 = Replace(Infos(83), "top.albumsPochettes[4] = ", "") .Artist4 = Replace(Infos(84), "top.interpretesPochettes[4] = ", "") .Date4 = Replace(Infos(90), "top.sortiePochettes[4] = ", "") .Editeur4 = Replace(Infos(91), "top.labelPochettes[4] = ", "") .Image4 = "http://cache.yacast.fr" & Replace(Infos(24), " top.imagesPochettesSrc[4] = ", "") .Titre5 = Replace(Infos(95), "top.titresPochettes[5] = ", "") .Album5 = Replace(Infos(96), "top.albumsPochettes[5] = ", "") .Artist5 = Replace(Infos(97), "top.interpretesPochettes[5] = ", "") .Date5 = Replace(Infos(103), "top.sortiePochettes[5] = ", "") .Editeur5 = Replace(Infos(104), "top.labelPochettes[5] = ", "") .Image5 = "http://cache.yacast.fr" & Replace(Infos(26), " top.imagesPochettesSrc[5] = ", "") .Reussi = True End With Text = "" Kill (App.Path & "\info.txt") Exit Function Erreur: Yacast.Reussi = False End Function Function OuvreFichier(Fichier As String) As String Dim a As Integer a = FreeFile Open Fichier For Binary Access Read As #a Do While Not EOF(a) OuvreFichier = OuvreFichier & Input(1024, #a) Loop Close #a End Function Public Function TéléchargeFichier(Url As String, Chemin As String) As Boolean TéléchargeFichier = False ' Déclaration des variables locales et du buffer. Dim HandleInternetOpen As Long Dim HandleInternetOpenUrl As Long Dim ResInternetReadFile As Boolean Dim Buffer As String * 2048 Dim NumberOfBytesRead As Long Dim Taille As Long Dim SizeOfBuffer As Long Dim b As Integer ' Ouverture d'un point d'accès à Internet. HandleInternetOpen = InternetOpen("Radio", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0) ' Teste si l'ouverture du point d'accès a réussi. If HandleInternetOpen = 0 Then GoTo Erreur End If ' Connexion à l'adresse du fichier à télécharger. HandleInternetOpenUrl = InternetOpenUrl(HandleInternetOpen, Url, vbNullString, 0, INTERNET_FLAG_RELOAD, 0) ' Teste si la connexion s'est bien effectuée. If HandleInternetOpenUrl = 0 Then GoTo Erreur End If Buffer = vbNullString SizeOfBuffer = Len(Buffer) ' Lecture du code de status du . ResInternetReadFile = HttpQueryInfo(HandleInternetOpenUrl, HTTP_QUERY_STATUS_CODE, ByVal Buffer, SizeOfBuffer, 0) ' Teste si la lecture du code de status s'est bien effectuée. ' Teste si le code de status est 404. If Buffer = "404" Then GoTo Erreur End If Buffer = vbNullString SizeOfBuffer = Len(Buffer) ' Lecture de la taille du fichier à télécharger. ResInternetReadFile = HttpQueryInfo(HandleInternetOpenUrl, HTTP_QUERY_CONTENT_LENGTH, ByVal Buffer, SizeOfBuffer, 0) ' Teste si la lecture de la taille s'est bien effectuée. If ResInternetReadFile = False Then GoTo Erreur End If On Error GoTo Erreur ' Conversion de la taille en Long et placement du résultat dans la variable "Taille". Taille = CLng(Buffer) ' Initialisation de la barre de progression. NumberOfBytesRead = 1 b = FreeFile ' Ouverture du fichier de destination. Open Chemin For Binary Access Write As #b ' Boucle de lecture/écriture du fichier. Do While NumberOfBytesRead > 0 Buffer = vbNullString ' Remplissage du buffer par les caractères lus. ResInternetReadFile = InternetReadFile(HandleInternetOpenUrl, Buffer, Len(Buffer), NumberOfBytesRead) ' Teste si la lecture s'est bien déroulée. If ResInternetReadFile = False Then GoTo Erreur End If ' Ecriture du contenu du buffer dans le fichier de destination. Put #b, , Left$(Buffer, NumberOfBytesRead) DoEvents Loop Close #b ' Fermeture de la connexion à l'adresse du fichier. If HandleInternetOpenUrl <> 0 Then InternetCloseHandle (HandleInternetOpenUrl) End If ' Fermeture du point d'accès à Internet. If HandleInternetOpen <> 0 Then InternetCloseHandle (HandleInternetOpen) End If TéléchargeFichier = True Exit Function Erreur: ' Fermeture de la connexion à l'adresse du fichier. If HandleInternetOpenUrl <> 0 Then InternetCloseHandle (HandleInternetOpenUrl) End If ' Fermeture du point d'accès à Internet. If HandleInternetOpen <> 0 Then InternetCloseHandle (HandleInternetOpen) End If ' Teste la présence du fichier de destination. If Dir(Chemin) <> "" Then Close #b Kill (Chemin) End If End Function
J'ai aussi ajouté des radios non supportées dans cette source, comme Europe 2 et RFM, qui utilisent un javascript pour stocker leur infos.
http://www.vbfrance.com/article.aspx?ID=9552
Néanmoins, si tu as le courage, je dis bien le courage car ca va etre dur, de modifer mon programme pour qu'il gère ton affichage, ce serait bien cool !
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.