email.pas

收发MAPI E-Mail(非SMTP E-mail), 传真的构件

{*******************************************************}
{                                                       }
{  TEmail component for Borland Delphi 2.10.0           }
{                                                       }
{     Please see the online documentation for           }
{     contributors, copyright, and release history      }
{                                                       }
{*******************************************************}

unit Email; { Email.PAS, Email.HPP }

{$F+} { force far calls }

{$DEFINE UseGenericThunks}

{$DEFINE DEBUG}
{$IFNDEF DEBUG}
  {$D-} {$Q-} {$R-} {$S-}
{$ENDIF DEBUG}

{$I+} { I/O exceptions needed for CopyAttachment }


{$IFDEF WIN32}
  { most Borland 32 bit compilers do have a "resourcestring" now... }
  {$DEFINE RESSTRING}
{$ELSE}
  { ...but 16 bit compilers (Delphi 1, that is) definitely don't }
  {$UNDEF RESSTRING}
{$ENDIF WIN32}

{$IFDEF VER90}
  { Delphi 2.0 - no resourcestring }
  {$UNDEF RESSTRING}
{$ENDIF VER90}

{$IFDEF VER93}
  { C++ Builder 1.0 - no resourcestring }
  {$UNDEF RESSTRING}
{$ENDIF VER93}


interface

uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinTypes, WinProcs,
{$ENDIF WIN32}
  Classes,
  SysUtils,

  SMapi { SMAPI.HPP, SMAPI.PAS }; { this is our generic Simple MAPI wrapper }


const
{$IFNDEF WIN32}
  { 16 bit implementation limits }
  RECIP_MAX       = 65000 div SizeOf(TMapiRecipDesc);
  ATTACH_MAX      = 65000 div SizeOf(TMapiFileDesc);
{$ELSE}
  { arbitrary limits for 32 bit }
  RECIP_MAX       = MaxInt div SizeOf(TMapiRecipDesc);
  ATTACH_MAX      = MaxInt div SizeOf(TMapiFileDesc);
{$ENDIF WIN32}

{$IFDEF BCB}
  { Let's have some fun now:

      C++ Builder 3.0 has a bug in the Pascal header generator
      that will make it translate
           type SString = ShortString
      to
           typedef typedef ShortString SString;
           ;

      Really.

    We can work around this problem by emitting the typedef
    ourselves and disallow it to be auto-processed.

    It would all be less of a mess if BCB 1.0 would also
    know these (undocumented) directives... }

  {$IFDEF VER110} { apply this fix only to BCB 3.0 }
    {$HPPEMIT 'typedef ShortString SString;'}
    {$NODEFINE SString}
  {$ENDIF VER110}

  type
    SString = ShortString;
{$ELSE}
  type
  {$IFDEF WIN32}
    SString   = ShortString;
  {$ELSE}
    SString   = string;
  {$ENDIF WIN32}
{$ENDIF BCB}


type
  TRecipAccessArray     = array [0 .. (RECIP_MAX - 1)] of TMapiRecipDesc;
  TlpRecipArray         = ^TRecipAccessArray;

  TAttachAccessArray    = array [0 .. (ATTACH_MAX - 1)] of TMapiFileDesc;
  TlpAttachArray        = ^TAttachAccessArray;

  TszRecipName    = array [0 .. 256] of Char;
  TlpszRecipName  = ^TszRecipName;

  TszPathName     = array[0 .. 256] of Char;
  TlpszPathname   = ^TszPathname;

  TszFileName     = array[0 .. 256] of Char;
  TlpszFileName   = ^TszFileName;


const
  EMAIL_OK = SUCCESS_SUCCESS;

{--------------------------}
{ Define TEmail component. }
{--------------------------}

type
  EMapiUnavailable = class(Exception);

  TMapiErrorEvent = procedure(Sender   : TObject;
                              ErrorCode: LongInt) of object;

  TEmail = class(TComponent)
  private
    FShowDialog     : Boolean;                { launch dialog after SendMail ?  }
    FAcknowledge    : Boolean;                { acknowledge receipt ?           }
    FAttachment     : TStrings;               { list of attachments             }
    FAttPathNames   : TStrings;               { Attachments temp file names     }
    FCC             : TStrings;               { list of CC's                    }
    FBcc            : Tstrings;               { list of Blind CC's              }
    FDateRecvd      : SString;                { Message date                    }
    FDownLoadFirst  : Boolean;                { Download messages at logon      }
    FHeaderOnly     : Boolean;                { ReadMail with MAPI_ENVELOPE_ONLY}
    FLeaveUnread    : Boolean;                { ReadMail with MAPI_PEEK         }
    FMessageId      : SString;                { next message Id from GetNext... }
    FMessageType    : SString;                { message type if non-IPM message }
    FNewSession     : Boolean;                { log in with new session         }
    FNoAttachments  : Boolean;                { ReadMail w. MAPI_SUPPRESS_ATTACH}
    FOnBeforeLogon  : TNotifyEvent;
    FOnAfterLogon   : TNotifyEvent;
    FOnBeforeLogoff : TNotifyEvent;
    FOnAfterLogoff  : TNotifyEvent;
    FOnBeforeSaveMail: TNotifyEvent;
    FOnAfterSaveMail: TNotifyEvent;
    FOnBeforeSendMail: TNotifyEvent;
    FOnAfterSendMail: TNotifyEvent;
    FOnMapiError    : TMapiErrorEvent;
    FOriginator     : SString;                { Message originator              }
    FOrigAddress    : SString;                { Message Originator's address    }
    FPassword       : SString;                { password for MAPI logon         }
    FpLongText      : PChar;                  { (long)  message body pointer    }
    FProfile        : SString;                { profile string for MAPI logon   }
    FRecip          : TStrings;               { list of recipients              }
    FSubject        : SString;                { message subject text            }
    FText           : SString;                { (short) message body            }
    FTruncAttFN     : Boolean;                { truncate attachment filename    }
    FUnread         : Boolean;                { Message read/unread status      }
    FUnreadOnly     : Boolean;                { GetNextMessageID returns unread }
    FUseDefProfile  : Boolean;                { use default profile fr. registry}
    FUseLongMessageID: Boolean;               { allow long message ID - GroupWise}

    function  GetVersion: SString;
    function  GetMapiAvail: boolean;          { MAPI dll has been loaded ? }

    procedure SetRecip(const Recip: TStrings);
    procedure SetCC   (const CC   : TStrings);
    procedure SetBcc  (const Bcc  : TStrings);
    procedure SetAttachment(const Attachment : TStrings);
    function  ListToRecipArray(FArray          : TStrings;
                               AulRecipClass   : ULONG;
                               lpRecipArray    : TlpRecipArray;
                               var nRecipients : Integer) : Integer;

    procedure SetDownLoadFirst(bDownLoadFirst: boolean);
    procedure SetNewSession(bNewSession: boolean);
  protected
    hSession        : ULONG;                  { MAPI Session number.  }
    flLogonFlags    : ULONG;                  { flag for logon parameters }

    procedure CheckMapi; virtual;
    function TruncAttachmentFN(const LongFN: SString): SString; virtual;

    function SendMailEx(DoSave: boolean): Integer;

    procedure DoBeforeLogon; virtual;
    procedure DoAfterLogon; virtual;
    procedure DoBeforeLogoff; virtual;
    procedure DoAfterLogoff; virtual;
    procedure DoBeforeSaveMail; virtual;
    procedure DoAfterSaveMail; virtual;
    procedure DoBeforeSendMail; virtual;
    procedure DoAfterSendMail; virtual;
    procedure DoMapiError(ErrorCode: Integer); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function Address                                       : Integer;
    function CheckAttachment(const AnAttachment : SString) : SString;
    function CheckRecipient (const ARecipient   : SString) : SString;
    procedure Clear;
    function CopyAttachment (Index              : Integer;
                             const DestPathName : SString;
                             DeleteAfterCopy    : Boolean) : Integer;
    function CountUnread                                   : ULONG;
    function DeleteMail                                    : Integer;
    procedure DownLoad;
    function GetLongText                                   : PChar;
    function GetNextMessageId                              : SString;
    function Logoff                                        : Integer;
    function Logon                                         : Integer;
    function ReadMail                                      : Integer;
    function SendMail                                      : Integer;
    function SaveMail                                      : Integer;
    function SetLongText(pLongText : PChar)                : Integer;

    property AttPathNames : TStrings read FAttPathNames;
    property DateRecvd    : SString read FDateRecvd;
    property HeaderOnly   : Boolean read FHeaderOnly    write FHeaderOnly
                                    Default False;
    property LeaveUnread  : Boolean read FLeaveUnread   write FleaveUnread
                                    Default True;
    property MessageId    : SString read FMessageId     write FMessageId;
    property MessageType  : SString read FMessageType   write FMessageType;
    property Originator   : SString read FOriginator;
    property OrigAddress  : SString read FOrigAddress;
    property NoAttachments: Boolean read FNoAttachments write FNoAttachments
                                    Default False;
    property Unread       : Boolean read Funread;

  published
    property Acknowledge  : Boolean     read FAcknowledge   write FAcknowledge
                                        default false;
    property Attachment   : TStrings    read FAttachment    write SetAttachment;
    property Bcc          : TStrings    read FBcc           write SetBcc;
    property CC           : TStrings    read FCC            write SetCC;
    property DownLoadFirst: Boolean     read FDownLoadFirst write SetDownLoadFirst;
    property MapiAvail    : boolean     read GetMapiAvail;
    property NewSession   : boolean     read FNewSession    write SetNewSession;
    property OnBeforeLogon   : TNotifyEvent    read FOnBeforeLogon    write FOnBeforeLogon;
    property OnAfterLogon    : TNotifyEvent    read FOnAfterLogon     write FOnAfterLogon;
    property OnBeforeLogoff  : TNotifyEvent    read FOnBeforeLogoff   write FOnBeforeLogoff;
    property OnAfterLogoff   : TNotifyEvent    read FOnAfterLogoff    write FOnAfterLogoff;
    property OnBeforeSaveMail: TNotifyEvent    read FOnBeforeSaveMail write FOnBeforeSaveMail;
    property OnAfterSaveMail : TNotifyEvent    read FOnAfterSaveMail  write FOnAfterSaveMail;
    property OnBeforeSendMail: TNotifyEvent    read FOnBeforeSendMail write FOnBeforeSendMail;
    property OnAfterSendMail : TNotifyEvent    read FOnAfterSendMail  write FOnAfterSendMail;
    property OnMapiError     : TMapiErrorEvent read FOnMapiError      write FOnMapiError;
    property Password     : SString     read FPassword      write FPassword;
    property Profile      : SString     read FProfile       write FProfile;
    property Recipient    : TStrings    read FRecip         write SetRecip;
    property ShowDialog   : Boolean     read FShowDialog    write FShowDialog
                                        default False;
    property Subject      : SString     read FSubject       write FSubject;
    property Text         : SString     read FText          write FText;
    property TruncAttFN   : Boolean     read FTruncAttFN    write FTruncAttFN
                                        default true;
    property UnreadOnly   : boolean     read FUnreadOnly    write FUnreadOnly;
    property UseDefProfile: Boolean     read FUseDefProfile write FUseDefProfile
                                        default False;
    property UseLongMessageID: Boolean  read FUseLongMessageID write FUseLongMessageID
                                        default True;

    property Version      : SString     read GetVersion {stored false};

{   property UserName     : SString     read FUserName     write FUserName;     }
{   property UserPassword : SString     read FUserPassword write FUserPassword; }

  end;

{ procedure Register; has been moved to email16.pas and email32.pas respectively }

const
  TEMAIL_VERSION = '2.09.02';


implementation

uses
 {$IFDEF WIN32}
   Registry
 {$ELSE}
   Call32NT { for thunking 16bit -> 32bit }
 {$ENDIF WIN32};


{ Create object. }
{----------------}

constructor TEmail.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { create private stringlist objects }
  { we need to create string lists for the TStrings }
  FRecip        := TStringList.Create;
  FCC           := TStringList.Create;
  FBcc          := TStringList.Create;
  FAttachment   := TStringList.Create;
  FAttPathNames := TStringList.Create;

  { initialize private data defaults}
  FLeaveUnread   := True;
  FUseLongMessageID := True;

{ Delphi will initialize the following members automatically to zero
  hSession       := 0;
  FAcknowledge   := False;
  FMessageId     := '';
  FMessageType   := '';
  FHeaderOnly    := False;
  FNoAttachments := False;
  FDateRecvd     := '';
  FDownLoadFirst := False;
  FOnBeforeLogon    := nil;
  FOnAfterLogon     := nil;
  FOnBeforeLogoff   := nil;
  FOnAfterLogoff    := nil;
  FOnBeforeSaveMail := nil;
  FOnAfterSaveMail  := nil;
  FOnBeforeSendMail := nil;
  FOnAfterSendMail  := nil;
  FOnMapiError      := nil;
  FOriginator    := '';
  FOrigAddress   := '';
  FpLongText     := nil;
  FProfile       := '';
  FPassword      := '';
  FUseDefProfile := False;
  FShowDialog    := False;
  FText          := '';
  flLogonFlags   := 0;
}
  FTruncAttFN := true; { for compatibility with MJK's changes }
end;


{ Destroy object. }
{-----------------}

destructor TEmail.Destroy;
begin
  FBcc.Free;
  FBcc := nil;

  FCC.Free;
  FCC := nil;

  FRecip.Free;
  FRecip := nil;

  FAttachment.Free;
  Fattachment := nil;

  FAttPathNames.Free;
  FAttPathNames := nil;

  StrDispose(FpLongText); { free text }
  FpLongText := nil;

  try
    if hSession <> 0 then
      Logoff;
  except
  end;

  inherited Destroy;
end;


function TEmail.GetVersion: SString;
begin
  Result := TEMAIL_VERSION;
end;


function TEmail.GetMapiAvail: boolean;
begin
  Result := MapiAvailable; { call function in SMAPI.PAS }
end;

procedure TEmail.DoBeforeLogon;
begin
  if Assigned(FOnBeforeLogon) then
    FOnBeforeLogon(Self);
end;

procedure TEmail.DoAfterLogon;
begin
  if Assigned(FOnAfterLogon) then
    FOnAfterLogon(Self);
end;

procedure TEmail.DoBeforeLogoff;
begin
  if Assigned(FOnBeforeLogoff) then
    FOnBeforeLogoff(Self);
end;

procedure TEmail.DoAfterLogoff;
begin
  if Assigned(FOnAfterLogoff) then
    FOnAfterLogoff(Self);
end;

procedure TEmail.DoBeforeSaveMail;
begin
  if Assigned(FOnBeforeSaveMail) then
    FOnBeforeSaveMail(Self);
end;

procedure TEmail.DoAfterSaveMail;
begin
  if Assigned(FOnAfterSaveMail) then
    FOnAfterSaveMail(Self);
end;

procedure TEmail.DoBeforeSendMail;
begin
  if Assigned(FOnBeforeSendMail) then
    FOnBeforeSendMail(Self);
end;

procedure TEmail.DoAfterSendMail;
begin
  if Assigned(FOnAfterSendMail) then
    FOnAfterSendMail(Self);
end;

procedure TEmail.DoMapiError(ErrorCode: Integer);
begin
  if Assigned(FOnMapiError) then
    FOnMapiError(Self, ErrorCode);
end;


{ Test whether MAPI is available - if not, raise an exception }

procedure TEmail.CheckMapi;
{$IFDEF RESSTRING}
resourcestring
{$ELSE}
const
{$ENDIF RESSTRING}
  SNoMapi = 'MAPI services are not available on this system';
begin
  if not MapiAvailable then { call function in SMAPI.PAS }
    raise EMapiUnavailable.Create(SNoMapi);
end;

{ This is code to allow the component to thunk to the WIN32 API }

{$IFNDEF WIN32} {$IFDEF UseGenericThunks}
type
  HKEY = longint;
  PHKEY = ^HKEY;

  PDWORD = ^DWORD;

const
  HKEY_CURRENT_USER = $80000001;
  KEY_QUERY_VALUE = $0001;
  REG_SZ = 1;

  ERROR_SUCCESS = 0;
var
  id_W32RegCloseKey,
  id_W32RegOpenKeyEx,
  id_W32RegQueryValueEx: longint;

  W32RegCloseKey: function(hKey: HKEY; id: longint): longint;

  W32RegOpenKeyEx: function( hKey: HKEY; lpSubKey: PChar;
                             ulOptions: DWORD; samDesired: longint;
                             phkResult: PHKEY; id: longint): Longint;