procedure TForm1.Button2Click(Sender: TObject);
var
u : variant;
v : IDispatch;
s :
string;
ShellWindow: IShellWindows;
WB: IWebbrowser2;
spDisp: IDispatch;
IDoc1: IHTMLDocument2;
k: Integer;
procedure RecurseLinks(htmlDoc: variant);
var
BodyElement : variant;
ElementCo: variant;
HTMLFrames: variant;
HTMLWnd : variant;
j, i : integer;
begin
try
if VarIsEmpty(htmlDoc)
then
exit;
BodyElement := htmlDoc.body;
if BodyElement.tagName = '
BODY'
then
begin
ElementCo := htmlDoc.links;
j := ElementCo.Length - 1;
for i := 0
to j
do
begin
u := ElementCo.item(i);
s := u.href;
If ((Copy(s, 1, 7) = '
http://')
or (Copy(s, 1, 6) = '
ftp://'))
and (S[Length(S)] <> '
/')
Then
listLinks.Items.Add(s);
end;
end;
HTMLFrames := htmlDoc.Frames;
j := HTMLFrames.length - 1;
for i := 0
to j
do
begin
HTMLWnd := HTMLFrames.Item(i);
RecurseLinks(HTMLWnd.Document);
end;
except
end;
end;
// RecurseLinks
begin
ShellWindow := CoShellWindows.Create;
// get the running instance of Internet Explorer
for k := 0
to ShellWindow.Count
do
begin
spDisp := ShellWindow.Item(k);
if spDisp =
nil then Continue;
// QueryInterface determines if an interface can be used with an object
spDisp.QueryInterface(iWebBrowser2, WB);
if WB <>
nil then
begin
WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
if iDoc1 <>
nil then
begin
WB := ShellWindow.Item(k)
as IWebbrowser2;
begin
v := WB.Document;
listLinks.Clear;
RecurseLinks(v);
end;
end;
end;
end;
end;