Mega Code Archive
Save a webpage with images
<![CDATA[
Title: Save a webpage with images
Question: Ever wanted to duplicate the functionality of your favorite browser and save a web page with images to disk, well here is a simple example that does just that. I've created two functions, the other function just lets you pass in a progress bar to show the status of the operation.
Please note: It requires Indy to run.
Answer:
unit URLGet;
interface
uses
Classes, SysUtils, Forms, IdHTTP, ComCtrls;
procedure UrlDownloadToFile(URL, FileName: string); overload;
procedure UrlDownloadToFile(URL, FileName: string; PB: TProgressbar); overload;
implementation
procedure GetImages(html: string; Images: TStringList);
var
i, j: Integer;
tag: string;
link: string;
begin
html := StringReplace(html, #13#10, ' ', [rfReplaceAll]);
i := 1;
while (i begin
// we have a begin tag
if html[i] = ' begin
tag := '';
while (i '') do
begin
tag := tag + html[i];
inc(i);
end;
tag := tag + html[i];
//inc(i);
// we have the tag, see if it is an a href
link := '';
if pos('SRC=', UpperCase(tag)) 0 then
begin
j := 1;
while (j begin
if (tag[j] = '"') or (tag[j] = '''') then
begin
link := '';
inc(j);
while (j begin
link := link + tag[j];
inc(j);
if j 12 then
begin
if (tag[j + 1] = '"') then
break;
if (tag[j+1] = '''') then
break;
end;
end;
link := link + tag[j];
//inc(j);
break;
end;
inc(j);
end;
if link '' then
Images.Add(link);
end;
end;
inc(i);
end;
end;
procedure UrlDownloadToFile(URL, FileName: string);
var
s, dir, path: string;
i: Integer;
ms: TMemoryStream;
imgs, sFile: TStringList;
HTTP: TIdHTTP;
begin
imgs := TStringList.Create;
HTTP := TidHTTP.Create(Application);
sFile := TStringList.Create;
try
s := HTTP.Get(URL);
if s '' then
begin
if FileName '' then
begin
path := ChangeFileExt(FileName, '') + '_files';
CreateDir(path);
dir := ExtractFileName(ChangeFileExt(FileName, '')) + '_files\';
GetImages(s, imgs);
ms := TMemoryStream.Create;
try
for i := 0 to pred(imgs.Count) do
begin
ms.Clear;
HTTP.Get(URL + imgs[i], ms);
ms.Position := 0;
if ms.Size 0 then
ms.SaveToFile(dir + imgs[i]);
s := StringReplace(s, imgs[i], dir + imgs[i], [rfReplaceAll]);
end;
finally
FreeAndNil(ms);
end;
sFile.Text := s;
sFile.SaveToFile(FileName);
end;
end;
finally
FreeAndNil(sFile);
FreeAndNil(HTTP);
FreeAndNil(imgs);
end;
end;
procedure UrlDownloadToFile(URL, FileName: string; PB: TProgressbar); overload;
var
s, dir, path: string;
i: Integer;
ms: TMemoryStream;
imgs, sFile: TStringList;
HTTP: TIdHTTP;
begin
if Assigned(PB) then
begin
imgs := TStringList.Create;
HTTP := TidHTTP.Create(Application);
sFile := TStringList.Create;
try
s := HTTP.Get(URL);
if s '' then
begin
if FileName '' then
begin
path := ChangeFileExt(FileName, '') + '_files';
CreateDir(path);
dir := ExtractFileName(ChangeFileExt(FileName, '')) + '_files\';
GetImages(s, imgs);
ms := TMemoryStream.Create;
try
PB.Max := pred(imgs.Count);
for i := 0 to pred(imgs.Count) do
begin
ms.Clear;
HTTP.Get(URL + imgs[i], ms);
ms.Position := 0;
if ms.Size 0 then
ms.SaveToFile(dir + imgs[i]);
s := StringReplace(s, imgs[i], dir + imgs[i], [rfReplaceAll]);
PB.Position := i;
Application.ProcessMessages;
end;
finally
FreeAndNil(ms);
end;
sFile.Text := s;
sFile.SaveToFile(FileName);
end;
end;
finally
FreeAndNil(sFile);
FreeAndNil(HTTP);
FreeAndNil(imgs);
end;
end
else
UrlDownloadToFile(URL, FileName);
end;
end.
]]>