Synapse - Email Examples

From Free Pascal wiki
Revision as of 09:24, 20 March 2022 by Alextp (talk | contribs)
Jump to navigationJump to search

Q: How to send an e-mail in Lazarus?

A (forum user y.ivanov):

Here is my small helper unit for Synapse. The password is the sender password (for SMTP).

unit mailsendu;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, smtpsend;
 
type
 
  { TMySMTPSend }
 
  TMySMTPSend = class(TSMTPSend)
  private
    FSendSize: Integer;
  protected
    function SendToRaw(const AFrom, ATo: String; const AMailData: TStrings)
      : Boolean;
  public
    function SendMessage(AFrom, ATo, ASubject: String; AContent,
      AAttachments: TStrings): Boolean;
 
    property SendSize: Integer read FSendSize write FSendSize;
 
  end;
 
implementation
 
uses
  ssl_openssl, mimemess, mimepart, synautil, synachar;
 
{ TMySMTPSend }
 
function TMySMTPSend.SendToRaw(const AFrom, ATo: String; const AMailData
  : TStrings): Boolean;
var
  S, T: String;
begin
  Result := False;
  if Self.Login then
  begin
    FSendSize := Length(AMailData.Text);
    if Self.MailFrom(GetEmailAddr(AFrom), FSendSize) then
    begin
      S := ATo;
      repeat
        T := GetEmailAddr(Trim(FetchEx(S, ',', '"')));
        if T <> '' then
          Result := Self.MailTo(T);
        if not Result then
          Break;
      until S = '';
      if Result then
        Result := Self.MailData(AMailData);
    end;
    Self.Logout;
  end;
end;
 
function TMySMTPSend.SendMessage(AFrom, ATo, ASubject: String; AContent,
  AAttachments: TStrings): Boolean;
var
  Mime: TMimeMess;
  P: TMimePart;
  I: Integer;
begin
  Mime := TMimeMess.Create;
  try
    // Set some headers
    Mime.Header.CharsetCode := UTF_8;
    Mime.Header.ToList.Text := ATo;
    Mime.Header.Subject := ASubject;
    Mime.Header.From := AFrom;
 
    // Create a MultiPart part
    P := Mime.AddPartMultipart('mixed', Nil);
 
    // Add as first part the mail text
    Mime.AddPartTextEx(AContent, P, UTF_8, True, ME_8BIT);
 
    // Add all attachments:
    if Assigned(AAttachments) then
      for I := 0 to Pred(AAttachments.Count) do
        Mime.AddPartBinaryFromFile(AAttachments[I], P);
 
    // Compose message
    Mime.EncodeMessage;
 
    // Send using SendToRaw
    Result := Self.SendToRaw(AFrom, ATo, Mime.Lines);
 
  finally
    Mime.Free;
  end;
end;
 
end.

This is how to use that unit:

program mailsend_test;
 
uses
  Classes, SysUtils, mailsendu, blcksock;
 
type
 
  { TSink }
 
  TSink = class(TObject)
    procedure Progress(Sender: TObject; Reason: THookSocketReason;const Value: String);
  end;
 
var
  Content, Attach: TStringList;
  SMTP: TMySMTPSend;
  Sink: TSink;
  Written: Integer;
 
{ TSink }
 
procedure TSink.Progress(Sender: TObject; Reason: THookSocketReason;
  const Value: String);
begin
  case Reason  of
    {:Socket connected to IP and Port. Connected IP and Port is in parameter in
     format like: 'localhost.somewhere.com:25'.}
    HR_Connect: Written := 0;
    {:report count of bytes writed to socket. Number is in parameter string. If
     you need is in integer, you must use StrToInt function!}
    HR_WriteCount:
      begin
        Written := Written + StrToInt(Value);
        WriteLn('Written ', Written, ' of ', SMTP.SendSize, ' bytes');
      end;
    {:report situation where communication error occured. When raiseexcept is
     @true, then exception is called after this Hook reason.}
    HR_Error: WriteLn('Error: ', Value);
  end;
end;
 
begin
  Sink := TSink.Create;
  Content := TStringList.Create;
  Content.Add('Hello!');
  Content.Add('This is a SMTP send test.');
  Content.Add('Hello from the other side!');
  Content.Add('Regards,');
  Attach := TStringList.Create;
  Attach.Add('mismisc.pas');
  Attach.Add('notused.pas');
 
  SMTP := TMySMTPSend.Create;
  try
    SMTP.TargetHost := 'smtp.googlemail.com';
    SMTP.TargetPort := '465';
    SMTP.Username := 'user@gmail.com';
    SMTP.Password := 'password here';
    SMTP.FullSSL := True;
    SMTP.Sock.OnStatus := @Sink.Progress;
    SMTP.Sock.RaiseExcept := True;
    try
      if SMTP.SendMessage(
        'user@gmail.com', // AFrom
        'recipient@domain.com', // ATo
        'Test subject FullSSL 2', // ASubject
        Content,
        Attach)
      then
        WriteLn('Success.')
      else
      begin
        WriteLn('Failure!');
      end;
    except
      on E: Exception do
        WriteLn('EXCEPTION: ', E.Message);
    end;
 
    with SMTP do
    begin
      WriteLn;
      WriteLn('  ResultCode: ', ResultCode);
      WriteLn('ResultString: ', ResultString);
      WriteLn('  FullResult: ', FullResult.Text);
      WriteLn('    AuthDone: ', AuthDone) ;
    end;
  finally
    SMTP.Free;
  end;
 
end.