Retirar Email de uma pagina com código Html

Vamos fazer uma rotina que pegue os emails que estão no html, da pagina Crie um novo projeto coloque um Edit, um TWebBrowser, e 1 memo e 2 Button vamos para o código:

Button1 mude o caption para Capturar

Button2 mude o caption para IR

declara e função ValidaEMail

Function ValidaEMail(const EMailIn: String):Boolean;
const
 CaraEsp: array[1..40] of string[1] =
 ( '!','#','$','%','¨','&','*',
 '(',')','+','=','§','¬','¢','¹','²',
 '³','£','´','`','ç','Ç',',',';',':',
 '<','>','~','^','?','/','','|','[',']','{','}',
 'º','ª','°');
var
 i,cont   : integer;
 EMail    : ShortString;
begin
 EMail := EMailIn;
 Result := True;
 cont := 0;
 if EMail <> '' then
 if (Pos('@', EMail)<>0) and (Pos('.', EMail)<>0) then    // existe @ .
 begin
 if (Pos('@', EMail)=1) or (Pos('@', EMail)= Length(EMail)) or 
  (Pos('.', EMail)=1) or (Pos('.', EMail)= Length(EMail)) or 
  (Pos(' ', EMail)<>0) then
 Result := False
 else                                   // @ seguido de . e vice-versa
 if (abs(Pos('@', EMail) - Pos('.', EMail)) = 1) then
 Result := False
 else
 begin
 for i := 1 to 40 do            // se existe Caracter Especial
 if Pos(CaraEsp[i], EMail)<>0 then
 Result := False;
 for i := 1 to length(EMail) do
 begin                                 // se existe apenas 1 @
 if EMail[i] = '@' then
 cont := cont + 1;                    // . seguidos de .
 if (EMail[i] = '.') and (EMail[i+1] = '.') then
 Result := false;
 end;
 // . no f, 2ou+ @, . no i, - no i, _ no i
 if (cont >=2) or ( EMail[length(EMail)]= '.' )
 or ( EMail[1]= '.' ) or ( EMail[1]= '_' )
 or ( EMail[1]= '-' )  then
 Result := false;
 // @ seguido de COM e vice-versa
 if (abs(Pos('@', EMail) - Pos('com', EMail)) = 1) then
 Result := False;
 // @ seguido de - e vice-versa
 if (abs(Pos('@', EMail) - Pos('-', EMail)) = 1) then
 Result := False;
 // @ seguido de _ e vice-versa
 if (abs(Pos('@', EMail) - Pos('_', EMail)) = 1) then
 Result := False;
 end;
 end
 else
 Result := False;
end;

No Bottão Captura Email

procedure TForm1.Button1Click(Sender: TObject);
var
 LinkPag: String;
 Retira,I : Integer;
 Linha : String;
 Posicao : Integer;
 Email : String;
 Arq : TextFile;
 documentoAtivo : variant;
begin
 Memo2.Lines.Clear;
 try
 while WebBrowser1.ReadyState <> READYSTATE_COMPLETE do
 begin
 Application.ProcessMessages;
 Sleep(0);
 end;
 finally
 documentoAtivo := WebBrowser1.Document;
 Memo2.Lines.Text:= documentoAtivo.Body.OuterHTML;
 end;

 Memo2.Lines.SaveToFile('C:\Arquivo.txt');
 Memo2.Lines.Clear;

 AssignFile(Arq, 'C:\Arquivo.txt');
 Reset(Arq);
 ReadLn ( arq, linha );
 while not EOF(Arq) do
 begin

 Linha := StringReplace(Linha,#13,'',[rfReplaceAll]);

 Posicao := pos('@',Linha);
 Retira := 1;
 Email  := '';
 if Posicao > 0 then
 begin
 while Pos(UpperCase(Linha[Posicao-Retira]),'.ABCDEFGHIJLMNOPQRSTUVXWYZ_01-23456789') <> 0 do
 begin
 Email := Linha[Posicao-Retira]+Email;
 Retira := Retira+1;
 end;

 if pos('.br',Linha) > 0 then
 Email := Email+copy(Linha,Posicao,pos('.br',Linha)-Posicao+3 )
 else if pos('.com',Linha) > 0 then
 Email := Email+Copy(Linha,Posicao ,pos('.com',Linha)-Posicao+4);

 if ValidaEMail(Email) then
 Memo2.Lines.Append(Email);
 end;
 ReadLn(Arq, Linha);
 end;
 CloseFile(Arq);
end;

No Botão IR

procedure TForm1.Button2Click(Sender: TObject);
begin
WebBrowser1.Navigate(Edit1.Text);
end;