Fórum Erro ao destruír objeto. #300609

unit mkMail;

interface

uses
  SysUtils, IdMessage, IdSMTP, Classes, Windows, Controls, LoginEmail, UEnviandoMail, Forms;

type
  TPrioridadeMsg = (pmUrgente, pmAlta, pmNormal, pmMedia, pmBaixa);

type
  TTipoMsg = (tmTexto, tmHTML, tmTextoHTML);

type
  TmkMail = class(TComponent)
  private
    FMensagem: TIdMessage;
    FSMTP: TIdSMTP;
    FHost: String;
    FUsuario: String;
    FComAutenticacao: Boolean;
    FSenha: String;
    FTipoDeAutenticacao: TAuthenticationType;
    FPara: String;
    FAssunto: String;
    FTexto: String;
    FDe: String;
    FEnviou: Boolean;                                                  
    FCopia: String;
    FCopiaOculta: String;
    FPrioridade: TPrioridadeMsg;
    FTipoMsg: TTipoMsg;
    FServidorReqAutenticacao: Boolean;
    FAnexo: TIdAttachment;
    FTemAnexo: Boolean;
    FArqAnexo: String;
    procedure SetHost(const Value: String);
    procedure SetUsuario(const Value: String);
    procedure SetComAutenticacao(const Value: Boolean);
    procedure SetSenha(const Value: String);
    procedure SetTipoDeAutenticacao(const Value: TAuthenticationType);
    procedure SetPara(const Value: String);
    function EmailValido(const Email: String): Boolean;
    procedure SetAssunto(const Value: String);
    procedure SetTexto(const Value: String);
    procedure SetDe(const Value: String);
    procedure SetCopia(const Value: String);
    procedure SetCopiaOculta(const Value: String);
    procedure SetPrioridade(const Value: TPrioridadeMsg);
    function GetPrioridade: TIdMessagePriority;
    procedure SetTipoMsg(const Value: TTipoMsg);
    procedure SetTemAnexo(const Value: Boolean);
    procedure SetArqAnexo(const Value: String);
    function Vazio(const S: String): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Erro(const S: String);
    procedure Conectar; virtual;
    procedure Desconectar;
    function Enviar: Boolean; virtual;
    function GetTipoMsg: String;
    property Host: String read FHost write SetHost;
    property Usuario: String read FUsuario write SetUsuario;
    property Senha: String read FSenha write SetSenha;
    property ComAutenticacao: Boolean read FComAutenticacao write
      SetComAutenticacao default False;
    property TipoDeAutenticacao: TAuthenticationType read FTipoDeAutenticacao
      write SetTipoDeAutenticacao default atNone;
    property De: String read FDe write SetDe;
    property Para: String read FPara write SetPara;
    property Copia: String read FCopia write SetCopia;
    property CopiaOculta: String read FCopiaOculta write SetCopiaOculta;
    property Assunto: String read FAssunto write SetAssunto;
    property Texto: String read FTexto write SetTexto;
    property Enviou: Boolean read FEnviou default False;
    property Prioridade: TPrioridadeMsg read FPrioridade
      write SetPrioridade default pmNormal;
    property TipoMsg: TTipoMsg read FTipoMsg write SetTipoMsg default tmTextoHTML;
    property TemAnexo: Boolean read FTemAnexo write SetTemAnexo;
    property ArqAnexo: String read FArqAnexo write SetArqAnexo;
  end;

implementation

//uses LoginEmail, UEnviandoMail;

{ TmkMail }

procedure TmkMail.Conectar;
var
   FormLoginEmail: TFormLoginEmail;
begin
  with FSMTP do
  begin
    Host := FHost;
    AuthenticationType := TipoDeAutenticacao;
    if (AuthenticationType = atLogin) and ( (Usuario = ´´) or (Senha = ´´)) then
    begin
      try
        FormLoginEmail := TFormLoginEmail.Create(Self);
        FormLoginEmail.ShowModal;
        Usuario := FormLoginEmail.EditConta.Text;
        Senha := FormLoginEmail.EditSenha.Text;
      finally
        FormLoginEmail.Free;
      end;
    end;
    Username := Usuario;
    Password := Senha;
    Connect;
  end;//with
end;

constructor TmkMail.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMensagem := TIdMessage.Create(Self);
  FSMTP := TIdSMTP.Create(Self);
  FComAutenticacao := False;
  FTipoDeAutenticacao := atNone;
  FEnviou := False;
  FPrioridade := pmNormal;
  FTipoMsg := tmTextoHTML;
  FPara := ´´;
  FCopia := ´´;
  FCopiaOculta := ´´;
end;

procedure TmkMail.Desconectar;
begin
  FSMTP.Disconnect;
end;

procedure TmkMail.SetComAutenticacao(const Value: Boolean);
begin
  if FComAutenticacao <> Value then
  begin
    FComAutenticacao := Value;

    if FComAutenticacao then
      TipoDeAutenticacao := atLogin
    else
      TipoDeAutenticacao := atNone;
  end;//if

end;

procedure TmkMail.SetHost(const Value: String);
begin
  if Trim(Value) = ´´ then
    Erro(´O ´´host´´ deve ser informado.´);
  if FHost <> Value then
    FHost := Value;
end;

procedure TmkMail.SetPara(const Value: String);
var
  vPara: String;
begin
  vPara := LowerCase(Value);
  if EmailValido(vPara) then
    if FPara <> vPara then
      FPara := vPara;
end;

procedure TmkMail.SetSenha(const Value: String);
begin
  if FComAutenticacao and (Trim(Value) = ´´) then
    Erro(´A Senha deve ser informada quando o servidor exigir autenticação.´);
  if FSenha <> Value then
  begin
    FSenha := Value;
  end;//if
end;

procedure TmkMail.SetTipoDeAutenticacao(
  const Value: TAuthenticationType);
begin
  if FTipoDeAutenticacao <> Value then
    FTipoDeAutenticacao := Value;
end;

procedure TmkMail.SetUsuario(const Value: String);
begin
  if (Trim(Value) = ´´) and (FComAutenticacao) then
    Erro(´O Usuário deve ser informado quando o servidor exigir autenticação.´);
  if FUsuario <> Value then
    FUsuario := Value;
end;

function TmkMail.EmailValido(const Email: String): Boolean;
var
  vEmail: String;
begin
  //Ex.:marcio.koch@inforeasy.com.br
  //Minimo:aa@bb.cc
  Result := False;
  vEmail := Trim(Email);

  //Se for vazio e o e-mail principal tiver preenchido deixa passar.
  if (vEmail = ´´) and (FPara <> ´´) then
  begin
    Result := True;
    Exit;
  end;//if

  if Length(vEmail) < 8 then
    Erro(´E-mail ´´´ + Email + ´´´ inválido.´);

  if Pos(´@´, vEmail) = 0 then
    Erro(´E-mail ´´´ + Email + ´´´ inválido. Faltando ´´@´´´);

  if Pos(´@´, vEmail) < 3 then
    Erro(´E-mail ´´´ + Email + ´´´ inválido. ´´@´´ está em posição inválida.´);

  if Pos(´@´, vEmail) > Length(vEmail) - 3 then
    Erro(´E-mail ´´´ + Email + ´´´ inválido. ´´@´´ está em posição inválida.´);
  Result := True;
end;

procedure TmkMail.SetAssunto(const Value: String);
begin
  if Trim(Value) = ´´ then
    Erro(´O ´´Assunto´´ deve ser informado.´);
  if FAssunto <> Value then
    FAssunto := Value;
end;

procedure TmkMail.SetTexto(const Value: String);
begin
  if Trim(Value) = ´´ then
    Erro(´O texto da Mensagem precisa ser informado.´);
  if FTexto <> Value then
    FTexto := Value;
end;

procedure TmkMail.SetDe(const Value: String);
var
  vDe: String;
begin
  vDe := LowerCase(Value);
  if EmailValido(vDe) then
    if FDe <> vDe then
      FDe := vDe;
end;

function TmkMail.Enviar: Boolean;
var
  vErro: String;
  FormLoginEmail : TFormLoginEmail;
  FEnviandoMail : TFEnviandoMail;
begin
  Result := False;
  FEnviou := Result;

  FormLoginEmail := TFormLoginEmail.Create(Self);
  FEnviandoMail := TFEnviandoMail.Create(Application);
  try
    if ComAutenticacao and ( Vazio(Usuario) or Vazio(Senha) ) then
    begin
      FormLoginEmail.EditConta.Text := Para;
      if FormLoginEmail.ShowModal = mrOk then
      begin
        Usuario := FormLoginEmail.EditConta.Text;
        Senha := FormLoginEmail.EditSenha.Text;
      end//if
      else
      begin
        Erro(´O Usuário e Senha devem ser informados.´);
        Exit;
      end;//else
    end;//if

    Conectar;
    with FMensagem do
    begin
      ContentType := GetTipoMsg;
      From.Name := De;
      Subject := Assunto;
      Body.Text := Texto;
      Recipients.EMailAddresses := Para;
      //É uma lista futuramente poderia-se adicionar mais.
      if Copia <> ´´ then
        CCList.EMailAddresses := Copia;
      //Cópia Ocula
      if CopiaOculta <> ´´ then
        BccList.EMailAddresses := CopiaOculta;

      //Define a prioridade.
      Priority := GetPrioridade;

      if TemAnexo then
      begin
        FAnexo := TIdAttachment.Create(FMensagem.MessageParts, FArqAnexo);
        FAnexo.ExtraHeaders.Values[´Content-ID´]:= FArqAnexo;
      end;

    end;//with


    vErro := ´´;
    try
      FEnviandoMail.Show;
      FSMTP.Send(FMensagem);
      FEnviandoMail.Close;
    except
      on E: Exception do
      begin
        if Pos(AnsiLowerCase(´authentication failed´), AnsiLowerCase(E.Message)) > 0 then
          vErro := ´Falha na Autenticação: usuário ou senha inválidos.´;

        if Pos(AnsiLowerCase(´connection timed out´), AnsiLowerCase(E.Message)) > 0 then
          vErro := ´Falha na Conexão: verifique se você está conectado a internet.´;

        if Pos(AnsiLowerCase(´Socket Error´), AnsiLowerCase(E.Message)) > 0 then
          vErro := ´Falha na Conexão.´;


        if Vazio(vErro) then
          vErro := ´Não foi possível enviar o e-mail.´ + #13 + ´Erro retornado:´ + E.Message + 13 + ´Tipo do erro:´ + E.ClassName;

        Erro(vErro);  
       end;//do
    end;

    //Do servidor partiu com sucesso, mas se o destinatário receberá,
    //isto é outra história.
    Result := True;
    FEnviou := Result;
  finally
    Desconectar;
    FreeAndNil(FAnexo);
    FreeAndNil(FEnviandoMail);
    FreeAndNil(FormLoginEmail);
  end;//try finally
end;

procedure TmkMail.SetCopia(const Value: String);
var
  vCopia: String;
begin
  vCopia := LowerCase(Value);
  if EmailValido(vCopia) then
    if FCopia <> vCopia then
      FCopia := vCopia;
end;

procedure TmkMail.SetCopiaOculta(const Value: String);
var
  vCopiaOculta: String;
begin
  vCopiaOculta := LowerCase(Value);
  if EmailValido(vCopiaOculta) then
    if FCopiaOculta <> vCopiaOculta then
      FCopiaOculta := vCopiaOculta;
end;

procedure TmkMail.SetPrioridade(const Value: TPrioridadeMsg);
begin
  if FPrioridade <> Value then
    FPrioridade := Value;
end;

function TmkMail.GetPrioridade: TIdMessagePriority;
begin
  case Prioridade of
    pmUrgente : Result := mpHighest;
    pmAlta : Result := mpHigh;
    pmNormal : Result := mpNormal;
    pmMedia : Result := mpLow;
    pmBaixa : Result := mpLowest;
    else Result := mpNormal;
  end;//case
end;

procedure TmkMail.SetTipoMsg(const Value: TTipoMsg);
begin
  if FTipoMsg <> Value then
    FTipoMsg := Value;
end;

function TmkMail.GetTipoMsg: String;
begin
  case TipoMsg of
    tmTexto: Result := ´text´;
    tmHTML : Result := ´HTML´;
    tmTextoHTML :Result := ´text/HTML´;
    else
      Result := ´text/HTML´;
  end;
end;

procedure TmkMail.SetTemAnexo(const Value: Boolean);
begin
  FTemAnexo := Value;
end;

procedure TmkMail.SetArqAnexo(const Value: String);
begin
  FArqAnexo := Value;
end;

function TmkMail.Vazio(const S: String): Boolean;
begin
  Result := Trim(S) = ´´;
end;

procedure TmkMail.Erro(const S: String);
begin
  Application.MessageBox(PChar(S), PChar(´Ocorreu um Erro´), MB_ICONERROR+MB_OK);
  Abort;
end;

end.