FastReport_2022_VCL/Source/frxIOSendMAPI.pas

unit frxIOSendMAPI;
{$I frx.inc}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TMapiErrEvent = procedure(Sender: TObject; ErrCode: Integer) of object;

  TMapiControl = class(TComponent)
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
    private
    FSubject: string;
    FMailtext: string;
    FFromName: string;
    FFromAdress: string;
    FTOAdr: TStrings;
    FCCAdr: TStrings;
    FBCCAdr: TStrings;
    FAttachedFileName: TStrings;
//    FDisplayFileName: TStrings;
    FShowDialog: Boolean;
    FUseAppHandle: Boolean;

    FOnUserAbort: TNotifyEvent;
    FOnMapiError: TMapiErrEvent;
    FOnSuccess: TNotifyEvent;

    procedure SetToAddr(newValue : TStrings);
    procedure SetCCAddr(newValue : TStrings);
    procedure SetBCCAddr(newValue : TStrings);
    procedure SetAttachedFileName(newValue : TStrings);
  protected
  public
    ApplicationHandle: THandle;
    function Sendmail( User, Passwd: String ): String;
    procedure Reset();
    function GetName(mailaddress: String): AnsiString;
    function GetAddress(mailaddress: String): AnsiString;
  published
    property Subject: string read FSubject write FSubject;
    property Body: string read FMailText write FMailText;
    property FromName: string read FFromName write FFromName;
    property FromAdress: string read FFromAdress write FFromAdress;
    property Recipients: TStrings read FTOAdr write SetTOAddr;
    property CopyTo: TStrings read FCCAdr write SetCCAddr;
    property BlindCopyTo: TStrings read FBCCAdr write SetBCCAddr;
    property AttachedFiles: TStrings read FAttachedFileName write SetAttachedFileName;
//    property DisplayFileName: TStrings read FDisplayFileName;
    property ShowDialog: Boolean read FShowDialog write FShowDialog;
    property UseAppHandle: Boolean read FUseAppHandle write FUseAppHandle;

    property OnUserAbort: TNotifyEvent read FOnUserAbort write FOnUserAbort;
    property OnMapiError: TMapiErrEvent read FOnMapiError write FOnMapiError;
    property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
end;

implementation

uses Mapi;

{ TMapiControl }

constructor TMapiControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOnUserAbort := nil;
  FOnMapiError := nil;
  FOnSuccess := nil;
  FSubject := '';
  FMailtext := '';
  FFromName := '';
  FFromAdress := '';
  FTOAdr := TStringList.Create;
  FCCAdr := TStringList.Create;
  FBCCAdr := TStringList.Create;
  FAttachedFileName := TStringList.Create;
//  FDisplayFileName := TStringList.Create;
  FShowDialog := False;
  ApplicationHandle := Application.Handle;
end;

procedure TMapiControl.SetToAddr(newValue : TStrings);
begin
  FToAdr.Assign(newValue);
end;

procedure TMapiControl.SetCCAddr(newValue : TStrings);
begin
  FCCAdr.Assign(newValue);
end;

procedure TMapiControl.SetBCCAddr(newValue : TStrings);
begin
  FBCCAdr.Assign(newValue);
end;

procedure TMapiControl.SetAttachedFileName(newValue : TStrings);
begin
  FAttachedFileName.Assign(newValue);
end;

destructor TMapiControl.Destroy;
begin
  FTOAdr.Free;
  FCCAdr.Free;
  FBCCAdr.Free;
  FAttachedFileName.Free;
//  FDisplayFileName.Free;
  inherited destroy;
end;

procedure TMapiControl.Reset;
begin
  FSubject := '';
  FMailtext := '';
  FFromName := '';
  FFromAdress := '';
  FTOAdr.Clear;
  FCCAdr.Clear;
  FBCCAdr.Clear;
  FAttachedFileName.Clear;
//  FDisplayFileName.Clear;
end;

function TMapiControl.GetName(mailaddress: String): AnsiString;
var
  i: Integer;
begin
  for i:=1 to Length(mailaddress) do
  begin
    if mailaddress[i] = '<' then
    begin
      Result := AnsiString(Copy(mailaddress, 1, i - 1));
      break;
    end;
  end;
end;

function TMapiControl.GetAddress(mailaddress: String): AnsiString;
var
  b,e: Integer;
begin
  Result := AnsiString(mailaddress);
  b := LastDelimiter('<',mailaddress);
  e := LastDelimiter('>',mailaddress);
  if (b > 0) and (e > 0) and (b < e) then
    Result := AnsiString(Copy(mailaddress, b+1, e-b-1))
  else
    Result := AnsiString( mailaddress );
end;

{ Prepare and send E-mail via MAPI }
function TMapiControl.Sendmail( User, Passwd: String ): String;

  procedure PrepareAddress( rec: PMapiRecipDesc; dest: String; clas: Cardinal );
  var
    PName, PAddress: PAnsiChar;
    slen: Integer;
  begin
    PName := PAnsiChar(GetName(dest));
    slen := Length(PName) * 2;
    GetMem(rec^.lpszName, slen);
    CopyMemory( rec^.lpszName, PName, slen );
    PAddress := PAnsiChar('SMTP:' + GetAddress(dest));
    slen := Length(PAddress) * 2;
    GetMem(rec^.lpszAddress, slen);
    CopyMemory( rec^.lpszAddress, PAddress, slen );
    rec^.ulReserved := 0;
    rec^.ulEIDSize := 0;
    rec^.lpEntryID := nil;
    rec^.ulRecipClass := clas;
  end;

  function AddFileToThisMail( desc: PMapiFileDesc; name: String): PMapiFileDesc;
  var
    PPathName, PFileName: PAnsiChar;
    slen: Integer;
  begin
    PPathName := PAnsiChar(AnsiString(name));
    slen := Length(PPathName) * 2;
    GetMem(desc^.lpszPathName, slen);
    CopyMemory( desc^.lpszPathName, PPathName, slen );
    PFileName := PAnsiChar(AnsiString(ExtractFileName(name)));
    slen := Length(PFileName) * 2;
    GetMem(desc^.lpszFileName, slen);
    CopyMemory( desc^.lpszFileName, PFileName, slen );
    desc^.ulReserved := 0;
    desc^.flFlags := 0;
    desc^.nPosition := Cardinal(-1);
    desc^.lpFileType := nil;
    Inc(desc);
    Result := desc;
  end;

var
  MapiMessage: TMapiMessage;
  MStatus: Cardinal;
  Sender: TMapiRecipDesc;
  PRecip, Recipients: PMapiRecipDesc;
  PFiles, Attachments: PMapiFileDesc;
  i, RcpCount: Integer;
  AppHandle: THandle;
  MAPI_Session: Cardinal;
  DestinationAddress: String;

begin
  AppHandle := Application.Handle;
  MStatus := MapiLogon(AppHandle,
    {$IFDEF Delphi12} PAnsiChar(AnsiString(User)), PAnsiChar(AnsiString(Passwd))
    {$ELSE} PAnsiChar(User), PAnsiChar(Passwd)
    {$ENDIF},
    MAPI_NEW_SESSION, 0, @MAPI_Session);
  if MStatus = MAPI_E_LOGON_FAILURE then
  MStatus := MapiLogon(AppHandle,
    {$IFDEF Delphi12}PAnsiChar(AnsiString(User)), PAnsiChar(AnsiString(Passwd))
    {$ELSE} PAnsiChar(User), PAnsiChar(Passwd)
    {$ENDIF},
    MAPI_LOGON_UI, 0, @MAPI_Session);
  if MStatus <> SUCCESS_SUCCESS then
  begin
    Result := 'MAPI access denied';
    exit;
  end;

  MapiMessage.nRecipCount := FTOAdr.Count + FCCAdr.Count + FBCCAdr.Count;
  GetMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
  RcpCount := 0;
  PFiles := nil;

  try
    with MapiMessage do
    begin
      ulReserved := 0;

      lpszSubject := PAnsiChar(AnsiString(Self.FSubject));
      lpszNoteText := PAnsiChar(AnsiString(FMailText));

      lpszMessageType := nil;
      lpszDateReceived := nil;
      lpszConversationID := nil;
      flFlags := 0;

      Sender.ulReserved := 0;
      Sender.ulRecipClass := MAPI_ORIG;
      Sender.lpszName := PAnsiChar(GetName(FromName));
      Sender.lpszAddress := PAnsiChar(GetAddress(FromName));  // FromAdress
      Sender.ulEIDSize := 0;
      Sender.lpEntryID := nil;
      lpOriginator := @Sender;

      PRecip := Recipients;

      if nRecipCount > 0 then
      begin
        for i := 1 to FTOAdr.Count do
        begin
          DestinationAddress := FTOAdr.Strings[i - 1];
          PrepareAddress(PRecip, DestinationAddress, MAPI_TO);
          Inc( PRecip ) ;
          Inc( RcpCount );
        end;

        for i := 1 to FCCAdr.Count do
        begin
          DestinationAddress := FCCAdr.Strings[i - 1];
          PrepareAddress(PRecip, DestinationAddress, MAPI_CC);
          Inc(PRecip);
          Inc(RcpCount);
        end;

        for i := 1 to FBCCAdr.Count do
        begin
          DestinationAddress := FBCCAdr.Strings[i - 1];
          PrepareAddress(PRecip, DestinationAddress, MAPI_BCC);
          Inc(PRecip);
          Inc(RcpCount);
        end;
      end;
      lpRecips := Recipients;

      if FAttachedFileName.Count > 0 then
      begin
        nFileCount := FAttachedFileName.Count;
        GetMem(Attachments, MapiMessage.nFileCount * sizeof(TMapiFileDesc));
        PFiles := Attachments;
        if nFileCount > 0 then
        begin
          for i := 0 to FAttachedFileName.Count - 1 do
            Attachments :=  AddFileToThisMail( Attachments, FAttachedFileName[i] );
        end;
        lpFiles := PFiles;
      end
      else
      begin
        nFileCount := 0;
        lpFiles := nil;
      end;
    end;

    MStatus := MapiSendMail( MAPI_Session, AppHandle, MapiMessage, 0, 0 );

    case MStatus of
      MAPI_E_USER_ABORT:
      begin
        Result := 'Mail sending procedure aborted by user';
        if Assigned(FOnUserAbort) then
          FOnUserAbort(Self);
      end;
      SUCCESS_SUCCESS:
      begin
        Result := '';
        if Assigned(FOnSuccess) then
          FOnSuccess(Self);
      end
      else
      begin
        Result := 'MAPI error: ' + IntToStr(MStatus);
        if Assigned(FOnMapiError) then
          FOnMapiError(Self, MStatus);
      end;
    end;
  finally
    PRecip := Recipients;
    for i := 1 to RcpCount do
    begin
      FreeMem(PRecip^.lpszName);
      FreeMem(PRecip^.lpszAddress);
      Inc(PRecip);
    end;
    FreeMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));

    if PFiles <> nil then
    begin
      Attachments :=  PFiles;
      if MapiMessage.nFileCount > 0 then
      for i := 0 to MapiMessage.nFileCount - 1 do
      begin
        FreeMem(PFiles^.lpszPathName);
        FreeMem(PFiles^.lpszFileName);
        Inc(PFiles);
      end;
      FreeMem(Attachments);
    end;
    MapiLogOff(MAPI_Session, AppHandle, 0, 0);
  end;
end;
end.