codice:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
RegExpr,ExtActns,HTTPSend,
Dialogs, StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
txtLink: TEdit;
txtVideo: TEdit;
txtVideoTitle: TEdit;
btnDownload: TButton;
ProgressBar1: TProgressBar;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
SaveDialog1: TSaveDialog;
Button1: TButton;
Label4: TLabel;
procedure btnExtractClick(Sender: TObject);
procedure btnDownloadClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
function formatFileName(s:String):String;
procedure URL_OnDownloadProgress (Sender: TDownLoadURL; Progress, ProgressMax:
Cardinal; StatusCode: TURLDownloadStatus; StatusText: String; var Cancel:
Boolean) ;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function ExtractVideoTitle(s: String): String;
const
sRegExpr = '<title>YouTube - ([^<]+)<';
var
r: TRegExpr;
begin
// Init
r := TRegExpr.Create;
try
// Set Expression
r.Expression := sRegExpr;
// Extract
if r.Exec(s) then
begin
// Set Result
// showmessage('test');
Result := r.Match[0];
// Format
Result := StringReplace(Result, '<title>YouTube - ', '', []);
Result := StringReplace(Result, '<', '', []);
end;
finally
r.Free;
end;
end;
function ExtractVideoLink(s: String): String;
const
sRegExpr1 = 'video_id":\s"([^"]+)"';
sRegExpr2 = '"t":\s"(.*?)"';
var
r: TRegExpr;
sID, sT: String;
begin
// Init
r := TRegExpr.Create;
try
// Get ID
// Set Expression
r.Expression := sRegExpr1;
// Get it
if r.Exec(s) then
begin
sID := r.Match[0];
sID := StringReplace(sID, ': ', '=', []);
sID := StringReplace(sID, #34, '', [rfReplaceAll]);
// showmessage('ok');
end;
//showmessage(sID);
// Get T
// Set Expression
r.Expression := sRegExpr2;
// Get it
if r.Exec(s) then
begin
sT := r.Match[0];
sT := StringReplace(sT, ': ', '=', []);
sT := StringReplace(sT, #34, '', [rfReplaceAll]);
end;
// Set Result
Result := 'http://youtube.com/get_video?' + sID + '&' + sT;
finally
r.Free;
end;
end;
procedure TForm1.btnExtractClick(Sender: TObject);
var
sHTTPSource:TStringList;
HTTP: THTTPSend;
begin
try
sHTTPSource := TStringList.Create;
if HttpGetText(txtLink.Text, sHTTPSource) then
begin
txtVideoTitle.Text := ExtractVideoTitle( sHTTPSource.Text );
txtVideo.Text := ExtractVideoLink( sHTTPSource.Text );
end;
finally
sHTTPSource.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sHTTPSource:TStringList;
HTTP: THTTPSend;
begin
try
sHTTPSource := TStringList.Create;
//use HttpGetText to save html source into TstringList
if HttpGetText(txtLink.Text, sHTTPSource) then
begin
txtVideoTitle.Text := ExtractVideoTitle( sHTTPSource.Text );
txtVideo.Text := ExtractVideoLink( sHTTPSource.Text );
end;
finally
sHTTPSource.Free;
end;
end;
//ensure file name is acceptable by windows
function TForm1.formatFileName(s: String): String;
var
I:Integer;
sTemp:String;
begin
sTemp:=StringReplace(s, ':', '', [rfReplaceAll]);
sTemp:=StringReplace(sTemp, ' ', '_', [rfReplaceAll]);
result := sTemp;
end;
procedure TForm1.URL_OnDownloadProgress(Sender: TDownLoadURL; Progress,
ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: String; var
Cancel: Boolean) ;
begin
ProgressBar1.Max:= ProgressMax;
ProgressBar1.Position:= Progress;
application.ProcessMessages;
end;
function DoDownload(vURL, vLocation : String): Boolean;
begin
with TDownloadURL.Create(nil) do
try
URL:= vURL;
FileName := vLocation;
OnDownloadProgress := Form1.URL_OnDownloadProgress;
ExecuteTarget(nil) ;
finally
Free;
end;
end;
procedure TForm1.btnDownloadClick(Sender: TObject);
var
FS: TFileStream;
begin
SaveDialog1.FileName := formatFileName(txtVideoTitle.Text);
if SaveDialog1.Execute then
begin
DoDownload(txtVideo.Text,SaveDialog1.FileName);
showmessage('done');
end;
end;
end.
ma quando lo eseguo ottengo l'errore "problems downloading url...": qualcuno sa dirmi perchè? grazie in anticipo per l'aiuto!