delphi HTML document接口获取网页中所有图片

uses mshtml, ActiveX, COMObj, IdHTTP, idURI;

{ .... }

procedure GetImageLinks(AURL: string; AList: TStrings);

var

IDoc: IHTMLDocument2;

strHTML: string;

v: Variant;

x: Integer;

ovLinks: OleVariant;

DocURL: string;

URI: TidURI;

ImgURL: string;

idHTTP: TidHTTP;

begin

AList.Clear;

URI := TidURI.Create(AURL);

try

DocURL := 'http://' + URI.Host;

if URI.Path <> '/' then

DocURL := DocURL + URI.Path;

finally

URI.Free;

end;

Idoc := CreateComObject(Class_HTMLDocument) as IHTMLDocument2;

try

IDoc.designMode := 'on';

while IDoc.readyState <> 'complete' do

Application.ProcessMessages;

v := VarArrayCreate([0, 0], VarVariant);

idHTTP := TidHTTP.Create(nil);

try

strHTML := idHTTP.Get(AURL);

finally

idHTTP.Free;

end;

v[0] := strHTML;

IDoc.Write(PSafeArray(System.TVarData(v).VArray));

IDoc.designMode := 'off';

while IDoc.readyState <> 'complete' do

Application.ProcessMessages;

ovLinks := IDoc.all.tags('IMG');

if ovLinks.Length > 0 then

begin

for x := 0 to ovLinks.Length - 1 do

begin

ImgURL := ovLinks.Item(x).src;

// The stuff below will probably need a little tweaking

// Deteriming and turning realtive URLs into absolute URLs

// is not that difficult but this is all I could come up with

// in such a short notice.

if (ImgURL[1] = '/') then

begin

// more than likely a relative URL so

// append the DocURL

ImgURL := DocURL + ImgUrl;

end

else

begin

if (Copy(ImgURL, 1, 11) = 'about:blank') then

begin

ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL));

end;

AList.Add(ImgURL);

end;

finally

IDoc := nil;

end;

// Beispiel:

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

GetImageLinks('http://www.swissdelphicenter.ch', Memo1.Lines);

end;

推荐分享