// Ein HTML-Quelltext wird nach EMail-Adressen abgesucht.

     
var erg:TStringlist;

procedure TForm1.FormCreate(Sender: TObject);
begin
erg:=TStringlist.create;
erg.sorted:=true;
erg.duplicates:=dupIgnore; // bei Bedarf dupAccept für doppelte Einträge
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
erg.free;
end;

function ok(c:char):boolean;
begin
result:=c in ['0'..'9','a'..'z','.','-','_'];
end;

function adresse(txt:string;var s:string):integer;
var i,x,y:integer;
sv,sn:string;
begin
result:=0;
i:=pos('@',txt);
if i>1 then begin
sv:='';
x:=i+1;
y:=x;
dec(i);
while (i>0) and (ok(txt[i])) do begin
sv:=txt[i]+sv;
dec(i);
end;
sn:='';
while (x<=length(txt)) and (ok(txt[x])) do begin
sn:=sn+txt[x];
inc(x);
end;
if sn[length(sn)]='.' then
delete(sn,length(sn),1);
if (sv='') or (sn='') or (pos('.',sn)=0) then
result:=y+adresse(copy(txt,y,length(txt)-y+1),s)-1
else begin
s:=sv+'@'+sn;
result:=y;
end;
end else s:='';
end;

procedure suchen(txt:string;var gefunden:TStringlist);
var
x,y:integer;
s:string;
begin
txt:=stringreplace(ansilowercase(txt),'&nbsp;',#32,[rfreplaceall]);
x:=1;
while x<=length(txt) do begin
if txt[x]<#32 then
while (x<=length(txt)) and (txt[x]<#33) do delete(txt,x,1)
else inc(x);
end;
gefunden.clear;
x:=1;
repeat
y:=adresse(copy(txt,x,length(txt)-x+1),s);
if s='' then exit
else gefunden.add(s);
x:=x+y+(length(s)-pos('@',s))-1;
until false;
end;

// Beispielaufruf
procedure TForm1.Button7Click(Sender: TObject);
var
sl:TStringlist;
begin
sl:=TStringlist.Create;
sl.loadfromfile('c:\Eigene Dateien\Eigene Webs\test.htm');
suchen(sl.text,erg);
if erg.count=0 then showmessage('nichts gefunden')
else begin
// ----- Auswertung von "erg" z.B.
showmessage('Es wurde(n) '+inttostr(erg.count)+' EMail-Adresse(n) gefunden'#13+
'Die erste lautet: '#13+erg[0]);
// -------------------------------
end;
sl.free;
end;