2
« en: Julio 26, 2011, 09:08:21 am »
Cinetube.bas
Option Explicit
'Apis Windows
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'Tipo donde para cada serie se guardaran los datos de nombre URL y la url de la imagen
Public Type Serie
Nombre As String
url As String
ImagenURL As String
End Type
'Direcciones que usa la API
Const CTURL As String = "http://www.cinetube.es/series/" 'URL de cinetube
Const CTSearchURL As String = "http://www.cinetube.es/buscar/series/?palabra=" 'URL de la pagina de busqueda de cinetube
'Matriz donde guardaremos los datos de las series en formato Type Serie
Public MatSeries() As Serie
Public Sub BuscarSerie(Serie As String)
Dim Data As String
Data = HTML(CTSearchURL & Serie)
Data = Between(Data, "<ul class=" & Chr(34) & "ver_series_list" & Chr(34) & ">", "</ul>")
CargarMatSeries Data, "<li>", "</li>"
End Sub
'*******************************************
'Grupo de funciones para que funcione la API
'*******************************************
'Carga la matriz de series
Public Sub CargarMatSeries(RawData As String, StartString As String, EndString As String)
Erase MatSeries()
Dim Comienzo As Long
Dim Final As Long
Dim Mydata As String
Dim Contador As Integer
Comienzo = 1
On Error GoTo Salir
While Comienzo <> 0
Comienzo = InStr(Comienzo, RawData, StartString)
Final = InStr(Comienzo, RawData, EndString)
Contador = Contador + 1
Mydata = Mid(RawData, Comienzo + Len(StartString), Final - Comienzo - Len(StartString))
'
ReDim Preserve MatSeries(1 To Contador)
MatSeries(Contador).url = CTURL & Between(Mydata, "/series/", "/")
MatSeries(Contador).ImagenURL = Between(Mydata, "src=" & Chr(34), Chr(34))
MatSeries(Contador).Nombre = Between(Mydata, "tit_ficha" & Chr(34) & ">", " <")
'
Mydata = ""
Comienzo = Final
Wend
Salir:
Exit Sub
End Sub
'Rellena un listView con los datos de las series cargados en Matseries()
Public Sub MostrarSeriesLV(ListView As ListView)
'Vaciamos el listview
ListView.ListItems.Clear
On Error GoTo Salix
'Si resulta que no tenemos elemntos en Matseries es que la busqueda no dio resultados y añadiremos "No se encontraron Resultados)
Dim n As Long
For n = 1 To UBound(MatSeries)
ListView.ListItems.Add , , AntiAcute(MatSeries(n).Nombre)
ListView.Enabled = True
Next n
Exit Sub
Salix:
ListView.ListItems.Add , , "No se encontraron resultados..."
ListView.Enabled = False
Form1.txtTemporada.Enabled = False
Form1.TxtLinks.Text = ""
Form1.LblCopy.Enabled = False
End Sub
'Descarga la imagen de la serie y la coloca en un picturebox
Public Sub PutImage(ImageUrl As String, Picturebox As Picturebox)
Picturebox.ScaleMode = vbPixels
Picturebox.ScaleWidth = 170
Picturebox.ScaleHeight = 262
URLDownloadToFile 0, ImageUrl, App.Path & "\tmp.jpg", 0, 0
Picturebox.Picture = LoadPicture(App.Path & "\tmp.jpg")
End Sub
'Guarda en un string la descripcion de la serie determinada por URL
Public Function GetSerieDescription(url As String) As String
Dim RawData As String
RawData = HTML(url & "/")
RawData = Between(RawData, "Ficha de la serie", "</p>")
RawData = RawData & "#"
RawData = Between(RawData, "<p>", "#")
GetSerieDescription = AntiAcute(RawData)
End Function
Public Function AntiAcute(Data As String) As String
Data = Replace(Data, "á", "á")
Data = Replace(Data, "é", "é")
Data = Replace(Data, "í", "í")
Data = Replace(Data, "ó", "ó")
Data = Replace(Data, "ú", "ú")
Data = Replace(Data, "Á", "Á")
Data = Replace(Data, "É", "É")
Data = Replace(Data, "Í", "Í")
Data = Replace(Data, "Ó", "Ó")
Data = Replace(Data, "Ú", "Ú")
Data = Replace(Data, "ñ", "ñ")
Data = Replace(Data, "Ñ", "Ñ")
Data = Replace(Data, "quot;", Chr(34))
AntiAcute = Data
End Function
Public Function GetTemporadas(url As String) As Integer
'De la pagina de una serie extrae el numero de temporadas que tiene
'URL : cinetube.es/series/titulo-de-la-serie/
Dim Comienzo As Long
Dim Final As Long
Dim Mydata As String
Dim Contador As Integer
Comienzo = 1
Dim StartString As String
Dim EndString As String
StartString = "Temporada "
EndString = "<"
Dim RawData As String
RawData = HTML(url & "/")
Debug.Print RawData
On Error GoTo Salir
While Comienzo <> 0
Comienzo = InStr(Comienzo, RawData, StartString)
Final = InStr(Comienzo, RawData, EndString)
Contador = Contador + 1
Mydata = Mid(RawData, Comienzo + Len(StartString), Final - Comienzo - Len(StartString))
'
GetTemporadas = Val(Mydata)
'
Mydata = ""
Comienzo = Final
Wend
Salir:
Exit Function
End Function
Public Function GetDownloadLink(url As String, Temporada As Integer, Capitulo As Integer) As String
'Extrae el link de descarga del capitulo
'URL : cinetube.es/series/titulo-de-la-serie/temporada-x/capitulo-x/
Dim RawData As String
RawData = HTML(url & "/temporada-" & Temporada & "/capitulo-" & Capitulo & "/")
RawData = Between(RawData, "v_online v_des", "html")
RawData = Between(RawData, "href=" & Chr(34), ".")
RawData = HTML("http://cinetube.es" & RawData & ".html")
RawData = Between(RawData, "xrxa(", ")+")
RawData = Between(RawData, "xrxa(" & Chr(34), Chr(34))
RawData = Reverse(RawData)
GetDownloadLink = RawData
DoEvents
End Function
Public Function Reverse(Cadena As String) As String
Dim n As Integer
For n = Len(Cadena) To 1 Step -1
Reverse = Reverse & Mid(Cadena, n, 1)
Next n
End Function
Public Sub GetAllDownloadLinks(url As String, Temporada As Integer, LV As ListView)
Dim n As Integer
Dim link As String
For n = 1 To GetCapitulos(url, Temporada)
link = GetDownloadLink(url, Temporada, n)
If link <> "" Then
'LV.ListItems.Add , , GetDownloadLink(url, Temporada, n)
Dim subelemento As ListItem
Set subelemento = LV.ListItems.Add(, , link)
'Encabezado Filename
subelemento.SubItems(1) = GetMegaFileInfo(link).FileName
End If
DoEvents
Form1.LblStatus.Caption = "Recopilando..."
Form1.LblCopy.Enabled = False
Next n
Form1.LblStatus.Caption = "Terminado"
Form1.LblCopy.Enabled = True
End Sub
Public Function GetCapitulos(url As String, Temporada As Integer) As Integer
'De la pagina de una temporada extrae el numero de capitulos que tiene
'URL : cinetube.es/series/titulo-de-la-serie/temporada-x/
Dim Comienzo As Long
Dim Final As Long
Dim Mydata As String
Dim Contador As Integer
Comienzo = 1
Dim StartString As String
Dim EndString As String
StartString = "Ver ficha del capítulo"
EndString = "<"
Dim RawData As String
RawData = HTML(url & "/temporada-" & Temporada & "/")
Debug.Print RawData
On Error GoTo Salir
While Comienzo <> 0
Comienzo = InStr(Comienzo, RawData, StartString)
Final = InStr(Comienzo, RawData, EndString)
Contador = Contador + 1
Mydata = Mid(RawData, Comienzo + Len(StartString), Final - Comienzo - Len(StartString))
'
GetCapitulos = Val(Mydata)
'
Mydata = ""
Comienzo = Final
Wend
Salir:
Exit Function
End Function
Megaupload.bas
Option Explicit
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000
Public Type MegaFileInfo
FileName As String
FileSize As String
FileDescription As String
FileDirectDownloadURL As String
End Type
Public Function GetHTML(hURL As String, Optional hUserAgent As String = "Mozilla Firefox") As String
' // Función para descargar cualquier tipo de documento o texto de internet utilizando wininet.
Dim hInternet As Long
Dim hFile As Long
Dim hBuffer As String * 1000
Dim hRead As Long
hInternet = InternetOpen(hUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hInternet <> 0 Then
hFile = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
If hFile <> 0 Then
Do
Call InternetReadFile(hFile, hBuffer, 1000, hRead)
GetHTML = GetHTML & Left$(hBuffer, hRead)
If hRead = 0 Then Exit Do
DoEvents
Loop
End If
End If
If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
If hFile <> 0 Then Call InternetCloseHandle(hFile)
End Function
Public Function Text_Between_Words(Text As String, String1 As String, String2 As String) As String
Dim Pos1 As Long, Pos2 As Long, Start As Long
Pos1 = InStr(Text, String1)
If Pos1 <> 0 Then Start = Pos1 + Len(String1): Pos2 = InStr(Start, Text, String2) Else Exit Function
If Pos2 <> 0 Then Text_Between_Words = Mid$(Text, Start, Pos2 - Start)
End Function
'##################################################################################################
Public Function GetMegaFileInfo(url As String) As MegaFileInfo
On Error GoTo NoFile
Dim RawData As String
RawData = GetHTML(url)
GetMegaFileInfo.FileDirectDownloadURL = Text_Between_Words(RawData, "downloadlink" & Chr(34) & "><a href=" & Chr(34), Chr(34))
RawData = Text_Between_Words(RawData, "down_txt2", "</div>")
GetMegaFileInfo.FileName = Text_Between_Words(RawData, ">", "<")
GetMegaFileInfo.FileDescription = Trim(Text_Between_Words(RawData, "</strong>", "<br />"))
Dim n As Long
n = InStr(1, RawData, GetMegaFileInfo.FileDescription) + Len(GetMegaFileInfo.FileDescription)
RawData = Mid(RawData, n, Len(RawData) - n)
GetMegaFileInfo.FileSize = Trim(Text_Between_Words(RawData, "</strong>", "<br />"))
Exit Function
NoFile:
GetMegaFileInfo.FileName = "No se encontró el archivo"
End Function
Public Sub DownloadFile(url As String, Nombre As String)
URLDownloadToFile 0, url, Nombre, 0, 0
End Sub
Este para descargar code HTML de una WEb
Option Explicit
Public Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000
Public Function HTML(hURL As String, Optional hUserAgent As String = "Mozilla Firefox") As String
' // Función para descargar cualquier tipo de documento o texto de internet utilizando wininet.
Dim hInternet As Long
Dim hFile As Long
Dim hBuffer As String * 1000
Dim hRead As Long
hInternet = InternetOpen(hUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hInternet <> 0 Then
hFile = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
If hFile <> 0 Then
Do
Call InternetReadFile(hFile, hBuffer, 1000, hRead)
HTML = HTML & Left$(hBuffer, hRead)
If hRead = 0 Then Exit Do
DoEvents
Loop
End If
End If
If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
If hFile <> 0 Then Call InternetCloseHandle(hFile)
End Function
Tambien usa text_between_words()
Saludos!!
Mostrar Mensajes