Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
universaldownloader.bas
| Uploader: |  Name.and(2)=Andreas |
| Datum/Zeit: | 12.07.2008 11:19:14 |
#ifdef __FB_WIN32__
#include once "win/winsock2.bi"
#else
#include once "crt/netdb.bi"
#include once "crt/sys/socket.bi"
#include once "crt/netinet/in.bi"
#include once "crt/arpa/inet.bi"
#include once "crt/unistd.bi"
#endif
#ifndef recvbufflen
#define RECVBUFFLEN 16384
#endif
#ifndef newline
#define newline chr(13,10)
#endif
Declare Function httpget(server As String, path As String, hadd as string = "") As String ' httpget in sub von fb:porticula
Declare Sub downloadfile(sURL as String, sFile as String) '
Declare Sub printmenu()
Declare Sub youtubevideodownload()
Declare Sub myspace()
Sub InitWinsock Constructor
#ifdef __FB_WIN32__
'' init winsock
Dim wsaData As WSAData
If( WSAStartup( MAKEWORD( 1, 1 ), @wsaData ) <> 0 ) Then 'winsock vorbereiten
Print "Error: WSAStartup failed"
End 1
End If
#Endif
End Sub
Sub ExitWinsock Destructor
#ifdef __FB_WIN32__
WSACleanup
#Endif
End Sub
'####################
Function httpget(server As String, path As String, hadd as string = "") As String
Dim IP As Integer
Dim ia As in_addr
Dim s As SOCKET
Dim hostentry As hostent Ptr
Dim sendbuffer As String
Dim recvbuffer As Zstring * RECVBUFFLEN+1
Dim bytes As Integer
Dim sa As sockaddr_in
Dim in as string
ia.S_addr = inet_addr( server )
If ( ia.S_addr = INADDR_NONE ) Then
hostentry = gethostbyname( server )
If ( hostentry = 0 ) Then
return "IP couldn't be resolved!"
End If
IP = *cast( Integer Ptr, *hostentry->h_addr_list )
Else
IP = ia.S_addr
End If
s = opensocket( AF_INET, SOCK_STREAM, IPPROTO_TCP )
If( s = 0 ) Then
return "Socket couldn't be opened."
End If
sa.sin_port = htons( 80 )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = ip
If ( connect( s, cast( PSOCKADDR, @sa ), Len( sa )) = SOCKET_ERROR ) Then
closesocket( s )
return "Couldn't connect to host"
End If
sendBuffer = "GET /" + path + " HTTP/1.0" + NEWLINE + _
"Host: " + server + NEWLINE + _
"Connection: close" + NEWLINE + _
hadd + _
NEWLINE
If( send( s, sendBuffer, Len( sendBuffer ), 0 ) = SOCKET_ERROR ) Then
closesocket( s )
return "Couldn't send request"
End If
Do
bytes = recv( s, recvBuffer, RECVBUFFLEN, 0 )
If( bytes <= 0 ) Then
exit do
End If
recvbuffer[bytes] = 0
in += recvbuffer
Loop
shutdown( s, 2 )
closesocket( s )
return in
End Function
'##########################################
'###########################################
Sub downloadfile(sURL as String, sFile as String)' bloß URLdownloadtofile in einen Sub gepackt | code von fb code-beispiele
Dim URLDownloadToFile as function ( _
ByVal pCaller As Long, _
ByVal szURL As zString ptr, _
ByVal szFileName As zString ptr, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Dim lR As Long
Dim library As Any Ptr
library=dylibload( "urlmon.dll" )
URLDownloadToFile=dylibsymbol(library, "URLDownloadToFileA" )
lR = URLDownloadToFile(0, sURL, sFile, 0, 0)
If lR = 0 Then
Print "Download erfolgreich!"
Else
Print "Fehler beim Download!"
End If
End SUb
'#############################################
Sub printmenu() ' notmenü
CLS
Print "|---------------------------------------------|"
Print "| Titel |"
Print "|---------------------------------------------|"
Print ""
Print " 1: Youtube-Video downloaden"
Print " 2: Myspace-Musik downloaden"
Print " 3: Exit"
End Sub
'#########################################
Sub myspace()
Dim url as String
Dim code as String
Dim htmlcode as String
Dim lenhtml as Integer
Dim durl as string
Dim i AS Integer
Dim itext as String
Dim title as String
Dim j as Integer
CLS
Input "ID der Band: ", code
'code = MID(url,76,9)
itext = "/services/media/musicplayerxml.ashx?b=" + code
'Print itext
'sleep
htmlcode= httpget("mediaservices.myspace.com",itext)
'Print htmlcode 'http://mediaservices.myspace.com/services/media/musicplayerxml.ashx?b=209429278
'sleep
lenhtml= len(htmlcode)
For i=1 to lenhtml
durl= ""
'If Mid(htmlcode,i,6)= "title=" then
' For j= i+8 to lenhtml
' If Mid(htmlcode,i,1) ="" then
' Exit For
' Else
'title=title+Mid(htmlcode,i,1)
'EndIf
' Next
'EndIf
If Mid(htmlcode,i,5)= "durl=" then
For j= i+6 to lenhtml
If not Mid(htmlcode,j,1)= CHR(34) then
durl= durl + MID(htmlcode,j,1)
Else
Exit For
EndIF
Next
Print durl
Input "Name des Liedes: ", title
downloadfile(durl,"C:\" + title + ".mp3")
title=""
EndIf
Next
Print "Fertig...Eniki"
sleep
end Sub
'##################################################
Sub youtubevideodownload()
Dim url as String
Dim finurl as String
Dim url2 as String
Dim htmlcode as String
Dim lenhtml as Integer
Dim i as Integer
Dim tcode as String
Dim itext as String
Dim filetitle as String
CLS
'Input "URL des Videos: ", url
Input "VideoID: ", url2
Input "Name der Datei: ", filetitle
'url2= MID(url,31,11)
'Print url2
itext="/watch?v=" & url2 & "&feature=related"
'Print itext
'sleep
htmlcode= httpget("de.youtube.com",itext)
'Open "test.txt" for Binary as #1
'Print #1,htmlcode
'Close #1
lenhtml= len(htmlcode)
'For i=1 to lenhtml
'If MID(htmlcode,i,7)="<title>" then
' For i= i+8 to lenhtml
' If not MID(htmlcode,i,1)= "<" then
' filetitle= filetitle + MID(htmlcode,i,1)
' EndIF
'Next
'EndIf
'Next
'i=0
For i= 1 to lenhtml
If MID(htmlcode,i,4)= "OEgs" then
tcode= Mid(htmlcode,i,32)
Exit For
EndIf
Next
'Print tcode
'sleep
finurl="http://de.youtube.com/get_video?video_id=" + url2 + "&t=" + tcode
'Print finurl
'sleep
Print "Bitte warten"
downloadfile(finurl,"C:\" & filetitle & ".flv")
Print "Fertig...Eniki"
sleep
End SUb
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Dim k as String 'hauptprogramm mit menüaufruf
Do
printmenu()
k=""
Do
k=Inkey
Loop until k <>""
If k="1" then
youtubevideodownload()
ElseIf k="2" then
myspace()
ElseIF k="3" then
end
EndIF
loop
sleep