Fórum Verificar existência de @ #279081

If Pos(´@´, dbEdit1.text) > 0 then
ShowMessage(´É isto pode ser um email´);

If Pos(´@´, dbEdit1.text) > 0 then
ShowMessage(´É isto pode ser um email´);

const
  msg1 = ´Caractere(s) inválido(s) no início do e-mail.´;
  msg2 = ´Símbolo @ não foi encontrado.´;
  msg3 = ´Excesso do símbolo @.´;
  msg4 = ´Caractere(s) inválido(s) antes do símbolo @.´;
  msg5 = ´Caractere(s) inválido(s) depois do símbolo @.´;
  msg6 = ´Agrupamento de caractere(s) inválido(s) a esqueda do @.´;
  msg7 = ´Não existe ponto(s) digitado(s).´;
  msg8 = ´Ponto encontrado no final do e-mail.´;
  msg9 = ´Ausência de caractere(s) após o último ponto.´;
  msg10 = ´Excesso de ponto(s) a direita do @.´;
  msg11 = ´Ponto(s) disposto(s) de forma errada após o @.´;
  msg12 = ´Caractere(s) inválido(s) antes do ponto.´;
  msg13 = ´Caractere(s) inválido(s) depois do ponto.´;
 
var
  Form1: TForm1; { <--- Nome do meu formulário }
  vet_valido: array [0..35] of string = (´0´,´1´,´2´,´3´,´4´,´5´,´6´,´7´, ´8´,´9´,´a´,´b´,´c´,´d´,´e´,´f´, ´g´,´h´,´i´,´j´,´k´,´l´,´m´,´n´, ´o´,´p´,´q´,´r´,´s´,´t´,´u´,´v´, ´w´,´x´,´y´,´z´);
Depois de implementation {$R *.DFM} coloque a seguinte função:

function func_VerifEmail(email: string): boolean;
var
  i, j, tam_email, simb_arroba, simb_arroba2, qtd_arroba, qtd_pontos,
  qtd_pontos_esq, qtd_pontos_dir, posicao, posicao2, ponto, ponto2: integer;
  vet_email: array [0..49] of string; //50 posições, capacidade do Edit
  msg: string;
begin
  {Por Jaci Jr em 12-10-2001 (00:28 às 03:57)
  Contatos por jrcordeiro@eletroacre.com.br ou
  jrcordeiro@bol.com.br
  Nesta função (func_VerifEmail) é utilizada a função Copy, exemplo:
  Copy(s,i,t) significa trecho de s que começa em i com tamanho t}
 
  qtd_pontos:= 0; qtd_pontos_esq:= 0; qtd_pontos_dir:= 0; qtd_arroba:= 0;
  posicao:=0; posicao2:=0; simb_arroba:=0; simb_arroba2:=0; ponto:= 0;
  ponto2:= 0; msg:=´´;
  Result:= True;
 
  //Verificando parte inicial do E-mail
  tam_email:= Length(email);
  for i:= 0 to tam_email-1 do
  begin
  vet_email[i]:= Copy(email,i+1,1);
  if vet_email[i] = ´@´ then
  begin
  Inc(qtd_arroba);
  posicao:= i;
  end;
  end;
 
  if ((vet_email[0] = ´@´) or (vet_email[0] = ´.´) or (vet_email[0] = ´-´)) then
  begin
  Result:= False;
  msg:= msg1;
  end;
 
  //Verificando se tem o símbolo @ e quantos tem
  if qtd_arroba < 1 then
  begin
  Result:= False;
  msg:= msg2;
  end
  else if qtd_arroba > 1 then
  begin
  Result:= False;
  msg:= msg3 + ´ Encontrado(s): ´+IntToStr(qtd_arroba)+´.´;
  end
  else
  //Verificando o que vem antes e depois do símbolo @
  begin
  for i:=0 to 35 do
  begin
  if vet_email[posicao-1] <> vet_valido[i] then Inc(simb_arroba)
  else Dec(simb_arroba);
  if vet_email[posicao+1] <> vet_valido[i] then Inc(simb_arroba2)
  else Dec(simb_arroba2);
  end;
  if simb_arroba = 36 then
  begin
  //Antes do arroba há um símbolo desconhecido do vetor válido
  Result:= False;
  msg:= msg4;
  end
  else if simb_arroba2 = 36 then
  begin
  //Depois do arroba há um símbolo desconhecido do vetor válido
  Result:= False;
  msg:= msg5;
  end
  end;
 
  //Verificando se há pontos e quantos, e Verificando parte final do e-mail
  for j:=0 to tam_email-1 do
  if vet_email[j] = ´-´ then
  if ((vet_email[j-1] = ´.´) or (vet_email[j-1] = ´-´)) then
  begin
  Result:= False;
  msg:= msg6;
  end;
  for i:=0 to tam_email-1 do
  if vet_email[i] = ´.´ then
  begin
  Inc(qtd_pontos);
  posicao2:= i+1;
  if i > posicao then Inc(qtd_pontos_dir)
  else Inc(qtd_pontos_esq);
  if ((vet_email[i-1] = ´.´) or (vet_email[i-1] = ´-´)) then
  begin
  Result:= False;
  msg:= msg6;
  end;
  end;
  if qtd_pontos < 1 then
  begin
  Result:= False;
  msg:= msg7;
  end
  else if vet_email[tam_email-1] = ´.´ then
  begin
  Result:= False;
  msg:= msg8;
  end
  else if vet_email[tam_email-2] = ´.´ then
  begin
  Result:= False;
  msg:= msg9;
  end
  else if qtd_pontos_dir > 2 then
  begin
  Result:= False;
  msg:= msg10 + ´ Encontrado(s): ´+
  IntToStr(qtd_pontos)+10+´Encontrado(s) a direita do @: ´+
  IntToStr(qtd_pontos_dir)+´.´;
  end
  else if (not ((((tam_email - posicao2) = 3) and (qtd_pontos_dir = 1)) or
  (((tam_email - posicao2) = 2) and (qtd_pontos_dir = 2)) or
  (((tam_email - posicao2) = 2) and (qtd_pontos_dir = 1)))) then
  begin
  Result:= False;
  msg:= msg11 +10+ ´Encontrado(s) a esquerda do @: ´+
  IntToStr(qtd_pontos_esq) +10+ ´Encontrado(s) a direita do @: ´+
  IntToStr(qtd_pontos_dir)+´.´;
  end
  else
  //Verificando o que vem antes e depois do ponto
  begin
  for i:=0 to 35 do
  begin
  if vet_email[posicao2-2] <> vet_valido[i] then Inc(ponto)
  else Dec(ponto);
  if vet_email[posicao2] <> vet_valido[i] then Inc(ponto2)
  else Dec(ponto2);
  end;
  if ponto = 36 then
  begin
  //Antes do ponto há um símbolo desconhecido do vetor válido
  Result:= False;
  msg:= msg12;
  end
  else if ponto2 = 36 then
  begin
  //Depois do ponto há um símbolo desconhecido do vetor válido
  Result:= False;
  msg:= msg13;
  end
  end;
 
  //Verificação final
  if not Result then
  begin
  msg:= msg +10+ ´Formato de E-mail não aceitável!!´;
  MessageDlg(msg,mtWarning,[mbRetry],0);
  end;
end;
 
{Os componentes devem ser configurados assim: O Form possui keypreview=true e evento onkeypress, o Edit possui evento onchange e o Button possui evento onclick. As procedures seguem abaixo}
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption:= ´´;
  if Trim(Edit1.Text)<>´´ then
  if (func_VerifEmail(Trim(Edit1.Text))) then
  begin
  Label1.Caption:= Trim(Edit1.Text)+´ está OK.´+#10+´Formato aceitável.´;
  Button1.Enabled:= False;
  end
  else
  begin Button1.SetFocus; Edit1.SetFocus; Edit1.SelText; end
end;
 
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = 13 then Button1Click(Sender);
  if (not ((Key in [´0´..´9´]) or (Key in [´A´..´Z´]) or
  (Key in [´a´..´z´]) or (Key = ´@´) or (Key = ´.´) or (Key = ´-´))) then
  Key:= 0;
end;
 
procedure TForm1.Edit1Change(Sender: TObject);
begin
  Label1.Caption:= ´´;
  Button1.Enabled:= True;
end;
//Ligue os eventos corretamente e verifique o resultado

 

{Dica Retirada do Site Delphi Journal}