Ну, раз так надо - могу предложить свой вариант.
Disclaimer: данный код является следствием экспериментов. Он не является оптимальным, безглючным, красивым, хорошим etc. Его можно оптимизировать до умопомрачения. Единственный его плюс - он работает. Не всегда, но работает. И настраивается... в определённых пределах.
Фактически самое сложное в этом - пропарсить HTML. Я искал хороший компонент-парсер, но бесплатных хороших нет, платить не хочется, а крякать пока лень. Так что я вернусь к этой задаче, как только она станет первоочередной  , а пока - вот код. Он сохраняет загруженную в TWebBrowser страничку вместе с картинками и скриптами. Эти файлы либо берутся из кэша Осла, либо докачиваются из инета. Код проверен на D7.
Unit1.pas
| Код |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, mshtml, StrUtils, ShDocVw, wininet, StdCtrls, OleCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
Button1: TButton;
Panel1: TPanel;
WebBrowser1: TWebBrowser;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
HTMLLinkedFolderSuffix='.files';
PortionSize=512;
var
Form1: TForm1;
ExtensionsList:TStrings;
implementation
{$R *.dfm}
function IsFullURL(Const URL: string): boolean;
begin
Result := (Pos('://', URL) <> 0) or (Pos('mailto:', Lowercase(URL)) <> 0);
end;
function AppearsInList(gLink:string; gList:TStrings):boolean;
begin
if gList.IndexOf(gLink)>-1
then result:=true
else result:=false;
end;//AppearsInList
{----------------Combine}
function Combine(Base, APath: string): string;
{combine a base and a path taking into account that overlap might exist}
{needs work for cases where directories might overlap}
var
I, J, K: integer;
begin
J := Pos('://', Base);
if J > 0 then
J := Pos('/', Copy(Base, J+3, Length(Base)-(J+2)))+J+2 {third slash}
else
J := Pos('/', Base);
if J = 0 then
begin
Base := Base+'/'; {needs a slash}
J := Length(Base);
end
else if Base[Length(Base)] <> '/' then
Base := Base + '/';
APath := Trim(APath);
if (APath <> '') and (APath[1] = '/') then
{remove path from base and use host only}
Result := Copy(Base, 1, J) + Copy(APath, 2, Length(APath)-1)
else Result := Base+APath;
{remove any '..\'s to simply and standardize for cacheing}
I := Pos('/../', Result);
while I > 0 do
begin
if I > J then
begin
K := I;
while (I > 1) and (Result[I-1] <> '/') do
Dec(I);
if I <= 1 then Break;
Delete(Result, I, K-I+4); {remove canceled directory and '/../'}
end
else
Delete(Result, I+1, 3); {remove '../' after host name}
I := Pos('/../', Result);
end;
{remove any './'s}
I := Pos('/./', Result);
while I > 0 do
begin
Delete(Result, I+1, 2);
I := Pos('/./', Result);
end;
end;
function IsURLAbsolute(gStr:string):boolean;
begin
if pos(':',gStr)>0
then result:=true
else result:=false;
end;//IsURLAbsolute
function GetURLFilenameAndExt(const URL: string): string;
var
I: integer;
begin
Result := URL;
for I := Length(URL) downto 1 do
if URL[I] = '/' then
begin
Result := Copy(URL, I+1, 255);
Break;
end;
end;
function ExtensionAllowed(gExt:string):boolean;
begin
if ExtensionsList.IndexOf(gExt)>-1
then result:=true
else result:=false;
end;//ExtensionAllowed
function FindFileToBring(var gStr:string;
StartPos:integer;
OpeningExpr:string;
ClosingExpr:string;
BasePath:string;
SaveDir:string;
ExternalLinks:TStrings):integer;
//finds an occurence of external files
var
StartFound:integer;
EndFound:integer;
Extracted:string;
WhereToStart:integer;
HowMany:integer;
cExt:string;
TargetLink:string;
begin
result:=0;
StartFound:=PosEx(OpeningExpr,gStr,StartPos);
if StartFound=0 then exit;
WhereToStart:=StartFound+length(OpeningExpr);
EndFound:=PosEx(ClosingExpr,gStr,WhereToStart);
if EndFound=0 then exit;
HowMany:=EndFound-WhereToStart;
Extracted:=copy(gStr,WhereToStart,HowMany);
cExt:=copy(ExtractFileExt(Extracted),2,24);
if ExtensionAllowed(cExt) then
begin
if not IsURLAbsolute(Extracted)
then TargetLink:=Combine(BasePath,Extracted)
else TargetLink:=Extracted;
if (not AppearsInList(TargetLink,ExternalLinks)) and (not IsFullURL(Extracted)) then ExternalLinks.Add(TargetLink);
TargetLink:=SaveDir+GetURLFilenameAndExt(Extracted);
Delete(gStr,WhereToStart,HowMany);
Insert(TargetLink,gStr,WhereToStart);
end;//if filter passed
result:=WhereToStart+length(TargetLink);
end;//FindFileToBring
procedure FindPairToBring(var gStr:string;
OpeningExpr:string;
ClosingExpr:string;
BasePath:string;
SaveDir:string;
ExternalLinks:TStrings);
var
cPos:integer;
begin
cPos:=1;
while cPos>0 do cPos:=FindFileToBring(gStr,cPos,OpeningExpr,ClosingExpr,BasePath,SaveDir,ExternalLinks);
end;//FindPairToBring
{----------------GetBase}
function GetBase(const URL: string): string;
{Given an URL, get the base directory}
var
I, J, LastSlash: integer;
S: string;
begin
S := Trim(URL);
J := Pos('?', S);
if J > 0 then
S := Copy(S, 1, J-1); {remove Query}
J := Pos('//', S);
LastSlash := 0;
for I := J+2 to Length(S) do
if S[I] = '/' then LastSlash := I;
if LastSlash = 0 then
Result := S+'/'
else Result := Copy(S, 1, LastSlash);
end;
procedure PrepareHTMLToSave(gStrs:TStrings;gWB:TWebBrowser;SaveDir:string;ExternalLinks:TStrings);
var
wstr:string;
BasePath:string;
begin
wstr:=gStrs.Text;
BasePath:=GetBase(gWB.LocationURL);
FindPairToBring(wstr,'url(',')',BasePath,SaveDir,ExternalLinks);
FindPairToBring(wstr,' background=',' ',BasePath,SaveDir,ExternalLinks);
FindPairToBring(wstr,' src="','"',BasePath,SaveDir,ExternalLinks);
gStrs.Text:=wstr;
end;//PrepareHTMLToSave
function GetHTMLLinkedFolderName(gFN:string):string;
var
cExt:string;
cName:string;
begin
cExt:=ExtractFileExt(gFN);
cName:=ExtractFileName(gFN);
result:=copy(cName,1,length(cName)-length(cExt))+HTMLLinkedFolderSuffix;
end;//GetHTMLLinkedFolderName
function DownloadFile(URL,FileName: string):boolean;
var
MegaBuffer:array of byte;
TotalRead:cardinal;
fH:integer;
function GetFile(const Url: string):boolean;
var
NetHandle: HInternet;
UrlHandle: HInternet;
Buffer: array[0..PortionSize-1] of byte;
BytesRead: cardinal;
begin
Result:=false;
NetHandle:=InternetOpen('ArbSurfer',
INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil,0);
if not Assigned(NetHandle) then exit;
Application.ProcessMessages;
UrlHandle:=InternetOpenUrl(NetHandle,
PChar(Url),
nil,0,
INTERNET_FLAG_RELOAD,0);
if not Assigned(UrlHandle) then
begin
InternetCloseHandle(NetHandle);
exit;
end;
Application.ProcessMessages;
TotalRead:=0;
SetLength(MegaBuffer,PortionSize);
repeat
if not InternetReadFile(UrlHandle,@Buffer,PortionSize,BytesRead) then exit;
move(Buffer,MegaBuffer[TotalRead],BytesRead);
TotalRead:=TotalRead+BytesRead;
FillChar(Buffer, PortionSize, 0);
SetLength(MegaBuffer,TotalRead+PortionSize);
Application.ProcessMessages;
until BytesRead=0;
InternetCloseHandle(UrlHandle);
result:=true;
end;//GetFile
begin
result:=false;
if URL='' then exit;
if FileName='' then exit;
if URL[2]=':' then URL:='file:///'+URL;
if copy(URL,1,8)='file:///' then URL:='file://'+copy(URL,9,length(URL));
if not GetFile(URL) then exit;
fH:=fileCreate(FileName);
if fH=-1 then exit;
fileWrite(fH,MegaBuffer[0],TotalRead);
fileClose(fH);
result:=true;
end;//DownloadFile
procedure DownloadFilesByList(gFilesList:TStrings;gTargetFolder:string);
var
i:integer;
begin
for i:=0 to gFilesList.Count-1 do
begin
Application.ProcessMessages;
DownloadFile(gFilesList[i],gTargetFolder+'\'+GetURLFilenameAndExt(gFilesList[i]));
end;//for
end;//DownloadFilesByList
procedure SaveWBFull(const FileName: string; WB: TWebBrowser);
var
wstrs:TStrings;
LinkedFolderAbs:string;
LinkedFolderName:string;
ExternalLinks:TStrings;
begin
wstrs:=TStringList.Create;
ExternalLinks:=TStringList.Create;
LinkedFolderName:=GetHTMLLinkedFolderName(FileName);
LinkedFolderAbs:=ExtractFileDir(FileName)+'\'+LinkedFolderName;
try
wstrs.Text:=WB.OleObject.Document.All.Tags('HTML').Item(0).OuterHTML;
PrepareHTMLToSave(wstrs,WB,LinkedFolderName+'\',ExternalLinks);
if ExternalLinks.Count>0 then
begin
if not DirectoryExists(LinkedFolderAbs) then
if not CreateDir(LinkedFolderAbs) then
begin
showmessage('Error creating folder '+LinkedFolderAbs);
ExternalLinks.Free;
wstrs.Free;
exit;
end;
DownloadFilesByList(ExternalLinks,LinkedFolderAbs);
end;//if there are aux. files to save
wstrs.SaveToFile(FileName);
except
{$IFDEF DebugMode}
showmessage('Error during SaveWBFull.');
{$ENDIF}
end;//except
ExternalLinks.Free;
wstrs.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate(Edit1.Text);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SaveWBFull(Edit2.Text,WebBrowser1);
showmessage('Download complete');
end;
initialization
ExtensionsList:=TStringList.Create;
ExtensionsList.Add('gif');
ExtensionsList.Add('jpg');
ExtensionsList.Add('png');
ExtensionsList.Add('js');
ExtensionsList.Add('css');
finalization
ExtensionsList.Free;
end.
|
Unit1.dfm
| Код |
object Form1: TForm1
Left = 211
Top = 80
Width = 475
Height = 306
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 8
Top = 8
Width = 23
Height = 13
Caption = 'From'
end
object Label2: TLabel
Left = 8
Top = 56
Width = 13
Height = 13
Caption = 'To'
end
object Edit1: TEdit
Left = 40
Top = 0
Width = 329
Height = 21
TabOrder = 0
Text = 'http://forum.vingrad.ru/index.php?showforum=84'
end
object Edit2: TEdit
Left = 40
Top = 48
Width = 329
Height = 21
TabOrder = 1
Text = 'D:\Tmp\saved.html'
end
object Button1: TButton
Left = 376
Top = 0
Width = 89
Height = 33
Caption = 'Go get it'
TabOrder = 2
OnClick = Button1Click
end
object Panel1: TPanel
Left = 16
Top = 88
Width = 441
Height = 185
Caption = 'Panel1'
TabOrder = 3
object WebBrowser1: TWebBrowser
Left = 1
Top = 1
Width = 439
Height = 183
Align = alClient
TabOrder = 0
ControlData = {
4C0000005F2D0000EA1200000000000000000000000000000000000000000000
000000004C000000000000000000000001000000E0D057007335CF11AE690800
2B2E126208000000000000004C0000000114020000000000C000000000000046
8000000000000000000000000000000000000000000000000000000000000000
00000000000000000100000000000000000000000000000000000000}
end
end
object Button2: TButton
Left = 376
Top = 40
Width = 89
Height = 33
Caption = 'Save to disk'
TabOrder = 4
OnClick = Button2Click
end
end
|
|
