[Tutorial] Retirar email de uma pagina com código Html [DELPHI]

[~ Heatlex. 11]

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

 

Declare a 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, EMail)<>0 then Result := False; for i := 1 to length(EMail) do begin // se existe apenas 1 @ if EMail = '@' then cont := cont + 1; // . seguidos de . if (EMail = '.') 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;

 

 

Retirado do Blog mundodoprogramador

É necessário se cadastrar para acessar o conteúdo.

• Entre
• ou
• Cadastre-se

 

link do Código fonte:

É necessário se cadastrar para acessar o conteúdo.

• Entre
• ou
• Cadastre-se