357 lines
9.5 KiB
ObjectPascal
357 lines
9.5 KiB
ObjectPascal
unit frxSendMAPI;
|
|
{$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;
|
|
FMAPISendFlag: Integer;
|
|
|
|
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;
|
|
property MAPISendFlag: Integer read FMAPISendFlag write FMAPISendFlag;
|
|
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, MAPISendFlag, 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.
|
|
|
|
|
|
|