Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Работа через MAPI

01.01.2007

Работа через MAPI

Пример с delphi.mastak.ru мне понравился(который нашел Song), я решил его сюда скопировать, может кому понадобится:

unit Email;
 
interface
 
uses
Windows, SusUtils, Classes;
 
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
function IsOnline: Boolean;
 
implementation
 
uses
Mapi;
 
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
var
MapiMessage: TMapiMessage;
MapiFileDesc: TMapiFileDesc;
MapiRecipDesc: TMapiRecipDesc;
i
: integer;
s
: string;
begin
with MapiRecipDesc do
begin
ulResved
:= 0;
ulRecipClass
:= MAPI_TO;
lpszName
:= PChar(RecipName);
lpszAddress
:= PChar(RecipAddress);
ulEIDSize
:= 0;
lpEntryID
:= nil;
 
end;
with MapiFileDesc do
begin
ulReserved
:= 0;
flFlags
:= 0;
nPosition
:= 0;
lpszPathName
:= PChar(Attachment);
lpszFileName
:= nil;
lpFileType
:= nil;
end;
with MapiMessage do
begin
ulReserved
:= 0;
lpszSubject
:= nil;
lpszNoteText
:= PChar(Subject);
lpszMessageType
:= nil;
lpszDateReceived
:= nil;
lpszConversationID
:= nil;
flFlags
:= 0;
lpOriginator
:= nil;
nRecipCount
:= 1;
lpRecips
:= @MapiRecipDesc;
 
if length(Attachment) > 0 then
   
begin
      nFileCount
:= 1;
      lpFiles
:= @MapiFileDesc;
   
end
 
else
   
begin
      nFileCount
:= 0;
      lpFiles
:= nil;
   
end;
end;
Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) = SUCCESS_SUCCESS;
end;
 
function IsOnline: Boolean;
var
RASConn: TRASConn;
dwSize
,dwCount: DWORD;
begin
RASConns.dwSize:= SizeOf(TRASConn);
dwSize
:= SizeOf(RASConns);
Res:=RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
Result:= (Res = 0) and (dwCount > 0);
end;
 
end.

Взято с Vingrad.ru https://forum.vingrad.ru


Автор: Sven Lohmann

Обычно в программах используется два способа отправки email. Первый - это "ShellExecute", а второй - через OLE server, как в Delphi 5. Однако, предлагаю посмотреть, как эта задача решается посредствам MAPI.

Совместимость: Delphi 4.x (или выше)

unit MapiControl; 
 
interface
 
uses
 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
type
 
{ Вводим новый тип события для получения Errorcode }
 
TMapiErrEvent = procedure(Sender: TObject; ErrCode: Integer) of object;
 
 
TMapiControl = class(TComponent)
   
constructor Create(AOwner: TComponent); override;
    destructor
Destroy; override;
 
private
   
{ Private-объявления }
   
FSubject: string;
   
FMailtext: string;
   
FFromName: string;
   
FFromAdress: string;
   
FTOAdr: TStrings;
   
FCCAdr: TStrings;
   
FBCCAdr: TStrings;
   
FAttachedFileName: TStrings;
   
FDisplayFileName: TStrings;
   
FShowDialog: Boolean;
   
FUseAppHandle: Boolean;
   
{ Error Events: }
   
FOnUserAbort: TNotifyEvent;
   
FOnMapiError: TMapiErrEvent;
   
FOnSuccess: TNotifyEvent;
   
{ +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
    procedure
SetToAddr(newValue : TStrings);
    procedure
SetCCAddr(newValue : TStrings);
    procedure
SetBCCAddr(newValue : TStrings);
    procedure
SetAttachedFileName(newValue : TStrings);
   
{ +< конец изменений }
 
protected
   
{ Protected-объявления }
 
public
   
{ Public-объявления }
   
ApplicationHandle: THandle;
    procedure
Sendmail();
    procedure
Reset();
  published
   
{ 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;
 
procedure
Register;
 
implementation
 
uses
Mapi;
 
{ регистрируем компонент: }
procedure
Register;
begin
 
RegisterComponents('expectIT', [TMapiControl]);
end;
 
{ 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;
 
{ +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
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;
 
{  Эта процедура составляет и отправляет Email }
procedure
TMapiControl.Sendmail;
var
 
MapiMessage: TMapiMessage;
 
MError: Cardinal;
 
Sender: TMapiRecipDesc;
 
PRecip, Recipients: PMapiRecipDesc;
 
PFiles, Attachments: PMapiFileDesc;
  i
: Integer;
 
AppHandle: THandle;
begin
 
{ Перво-наперво сохраняем Handle приложения, if not
    the
Component might fail to send the Email or
    your calling
Program gets locked up. }
 
AppHandle := Application.Handle;
 
 
{ Нам нужно зарезервировать память для всех получателей }
 
MapiMessage.nRecipCount := FTOAdr.Count + FCCAdr.Count + FBCCAdr.Count;
 
GetMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
 
 
try
   
with MapiMessage do
   
begin
      ulReserved
:= 0;
     
{ Устанавливаем поле Subject: }
      lpszSubject
:= PChar(Self.FSubject);
 
     
{ ...  Body: }
      lpszNoteText
:= PChar(FMailText);
 
      lpszMessageType
:= nil;
      lpszDateReceived
:= nil;
      lpszConversationID
:= nil;
      flFlags
:= 0;
 
     
{ и отправителя: (MAPI_ORIG) }
     
Sender.ulReserved := 0;
     
Sender.ulRecipClass := MAPI_ORIG;
     
Sender.lpszName := PChar(FromName);
     
Sender.lpszAddress := PChar(FromAdress);
     
Sender.ulEIDSize := 0;
     
Sender.lpEntryID := nil;
      lpOriginator
:= @Sender;
 
     
PRecip := Recipients;
 
     
{ У нас много получателей письма: (MAPI_TO)
       
установим для каждого: }
     
if nRecipCount > 0 then
     
begin
       
for i := 1 to FTOAdr.Count do
       
begin
         
PRecip^.ulReserved := 0;
         
PRecip^.ulRecipClass := MAPI_TO;
         
{ lpszName should carry the Name like in the
            contacts
or the adress book, I will take the
            email adress to keep it
short: }
         
PRecip^.lpszName := PChar(FTOAdr.Strings[i - 1]);
         
{ Если Вы используете этот компонент совместно с Outlook97 или 2000
           
(не Express версии) , то Вам прийдётся добавить
           
'SMTP:' в начало каждого (email-) адреса.
         
}
         
PRecip^.lpszAddress := PChar('SMTP:' + FTOAdr.Strings[i - 1]);
         
PRecip^.ulEIDSize := 0;
         
PRecip^.lpEntryID := nil;
         
Inc(PRecip);
       
end;
 
       
{ То же самое проделываем с получателями копии письма: (CC, MAPI_CC) }
       
for i := 1 to FCCAdr.Count do
       
begin
         
PRecip^.ulReserved := 0;
         
PRecip^.ulRecipClass := MAPI_CC;
         
PRecip^.lpszName := PChar(FCCAdr.Strings[i - 1]);
         
PRecip^.lpszAddress := PChar('SMTP:' + FCCAdr.Strings[i - 1]);
         
PRecip^.ulEIDSize := 0;
         
PRecip^.lpEntryID := nil;
         
Inc(PRecip);
       
end;
 
       
{ ... тоже самое для Bcc: (BCC, MAPI_BCC) }
       
for i := 1 to FBCCAdr.Count do
       
begin
         
PRecip^.ulReserved := 0;
         
PRecip^.ulRecipClass := MAPI_BCC;
         
PRecip^.lpszName := PChar(FBCCAdr.Strings[i - 1]);
         
PRecip^.lpszAddress := PChar('SMTP:' + FBCCAdr.Strings[i - 1]);
         
PRecip^.ulEIDSize := 0;
         
PRecip^.lpEntryID := nil;
         
Inc(PRecip);
       
end;
     
end;
      lpRecips
:= Recipients;
 
     
{ Теперь обработаем прикреплённые к письму файлы: }
 
     
if FAttachedFileName.Count > 0 then
     
begin
        nFileCount
:= FAttachedFileName.Count;
       
GetMem(Attachments, MapiMessage.nFileCount * sizeof(TMapiFileDesc));
 
       
PFiles := Attachments;
 
       
{ Во первых установим отображаемые на экране имена файлов (без пути): }
       
FDisplayFileName.Clear;
       
for i := 0 to FAttachedFileName.Count - 1 do
         
FDisplayFileName.Add(ExtractFileName(FAttachedFileName[i]));
 
       
if nFileCount > 0 then
       
begin
         
{ Теперь составим структурку для прикреплённого файла: }
         
for i := 1 to FAttachedFileName.Count do
         
begin
           
{ Устанавливаем полный путь }
           
Attachments^.lpszPathName := PChar(FAttachedFileName.Strings[i - 1]);
           
{ ... и имя, отображаемое на дисплее: }
           
Attachments^.lpszFileName := PChar(FDisplayFileName.Strings[i - 1]);
           
Attachments^.ulReserved := 0;
           
Attachments^.flFlags := 0;
           
{ Положение должно быть -1, за разьяснениями обращайтесь в WinApi Help. }
           
Attachments^.nPosition := Cardinal(-1);
           
Attachments^.lpFileType := nil;
           
Inc(Attachments);
         
end;
       
end;
        lpFiles
:= PFiles;
     
end
     
else
     
begin
        nFileCount
:= 0;
        lpFiles
:= nil;
     
end;
   
end;
 
   
{ Send the Mail, silent or verbose:
     
Verbose means in Express a Mail is composed and shown as setup.
     
In non-Express versions we show the Login-Dialog for a new
      session
and after we have choosen the profile to use, the
      composed email
is shown before sending
 
     
Silent does currently not work for non-Express version. We have
     
no Session, no Login Dialog so the system refuses to compose a
     
new email. In Express Versions the email is sent in the
      background
.
     
}
   
if FShowDialog then
     
MError := MapiSendMail(0, AppHandle, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0)
   
else
     
MError := MapiSendMail(0, AppHandle, MapiMessage, 0, 0);
 
   
{ Теперь обработаем сообщения об ошибках. В MAPI их присутствует достаточное.
     
количество. В этом примере я обрабатываю только два из них: USER_ABORT и SUCCESS,
     
относящиеся к специальным.
 
     
Сообщения, не относящиеся к специальным:
      MAPI_E_AMBIGUOUS_RECIPIENT
,
        MAPI_E_ATTACHMENT_NOT_FOUND
,
        MAPI_E_ATTACHMENT_OPEN_FAILURE
,
        MAPI_E_BAD_RECIPTYPE
,
        MAPI_E_FAILURE
,
        MAPI_E_INSUFFICIENT_MEMORY
,
        MAPI_E_LOGIN_FAILURE
,
        MAPI_E_TEXT_TOO_LARGE
,
        MAPI_E_TOO_MANY_FILES
,
        MAPI_E_TOO_MANY_RECIPIENTS
,
        MAPI_E_UNKNOWN_RECIPIENT
:
   
}
 
   
case MError of
      MAPI_E_USER_ABORT
:
       
begin
         
if Assigned(FOnUserAbort) then
           
FOnUserAbort(Self);
       
end;
      SUCCESS_SUCCESS
:
       
begin
         
if Assigned(FOnSuccess) then
           
FOnSuccess(Self);
       
end
   
else begin
       
if Assigned(FOnMapiError) then
         
FOnMapiError(Self, MError);
     
end;
 
   
end;
 
finally
   
{ В заключение освобождаем память }
   
FreeMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
 
end;
end;
 
{
 
Вопросы и замечания присылайте Автору.
}
 
end.

Взято из https://forum.sources.ru


 uses ..., MAPI;
 
// отправка письма с вложением
// =============================================================================
function SendEMail(Handle: THandle; Mail: TStrings): Cardinal;
type
 
TAttachAccessArray = array [0..0] of TMapiFileDesc;
 
PAttachAccessArray = ^TAttachAccessArray;
var
 
MapiMessage: TMapiMessage;
 
Receip: TMapiRecipDesc;
 
Attachments: PAttachAccessArray;
 
AttachCount: Integer;
  i1
: integer;
 
FileName: string;
  dwRet
: Cardinal;
  MAPI_Session
: Cardinal;
 
WndList: Pointer;
begin
 
Result := 0;
  dwRet
:= MapiLogon(Application.Handle,
   
nil,
   
nil,
    MAPI_NEW_SESSION
+ MAPI_LOGON_UI,
   
0, @MAPI_Session);
 
 
if (dwRet <> SUCCESS_SUCCESS) then
 
begin
   
MessageBox(Handle,
     
PChar('Error while trying to send email'),
     
PChar('Error'),
      MB_ICONERROR
or MB_OK);
 
end
 
else
 
begin
   
FillChar(MapiMessage, SizeOf(MapiMessage), #0);
   
Attachments := nil;
   
FillChar(Receip, SizeOf(Receip), #0);
 
   
if Mail.Values['to'] <> '' then
   
begin
     
Receip.ulReserved := 0;
     
Receip.ulRecipClass := MAPI_TO;
     
Receip.lpszName := StrNew(PChar(Mail.Values['to']));
     
Receip.lpszAddress := StrNew(PChar('SMTP:' + Mail.Values['to']));
     
Receip.ulEIDSize := 0;
     
MapiMessage.nRecipCount := 1;
     
MapiMessage.lpRecips := @Receip;
   
end;
 
   
AttachCount := 0;
 
   
for i1 := 0 to MaxInt do
   
begin
     
if Mail.Values['attachment' + IntToStr(i1)] = '' then
       
break;
     
Inc(AttachCount);
   
end;
 
   
if AttachCount > 0 then
   
begin
     
GetMem(Attachments, SizeOf(TMapiFileDesc) * AttachCount);
 
     
for i1 := 0 to AttachCount - 1 do
     
begin
       
FileName := Mail.Values['attachment' + IntToStr(i1)];
       
Attachments[i1].ulReserved := 0;
       
Attachments[i1].flFlags := 0;
       
Attachments[i1].nPosition := ULONG($FFFFFFFF);
       
Attachments[i1].lpszPathName := StrNew(PChar(FileName));
       
Attachments[i1].lpszFileName :=
         
StrNew(PChar(ExtractFileName(FileName)));
       
Attachments[i1].lpFileType := nil;
     
end;
     
MapiMessage.nFileCount := AttachCount;
     
MapiMessage.lpFiles := @Attachments^;
   
end;
 
   
if Mail.Values['subject'] <> '' then
     
MapiMessage.lpszSubject := StrNew(PChar(Mail.Values['subject']));
   
if Mail.Values['body'] <> '' then
     
MapiMessage.lpszNoteText := StrNew(PChar(Mail.Values['body']));
 
   
WndList := DisableTaskWindows(0);
   
try
   
Result := MapiSendMail(MAPI_Session, Handle,
     
MapiMessage, MAPI_DIALOG, 0);
   
finally
     
EnableTaskWindows( WndList );
   
end;
 
   
for i1 := 0 to AttachCount - 1 do
   
begin
     
StrDispose(Attachments[i1].lpszPathName);
     
StrDispose(Attachments[i1].lpszFileName);
   
end;
 
   
if Assigned(MapiMessage.lpszSubject) then
     
StrDispose(MapiMessage.lpszSubject);
   
if Assigned(MapiMessage.lpszNoteText) then
     
StrDispose(MapiMessage.lpszNoteText);
   
if Assigned(Receip.lpszAddress) then
     
StrDispose(Receip.lpszAddress);
   
if Assigned(Receip.lpszName) then
     
StrDispose(Receip.lpszName);
   
MapiLogOff(MAPI_Session, Handle, 0, 0);
 
end;
end;

 
 

пример вызова:

procedure TForm1.Button1Click(Sender: TObject);
var
 
Mail: TStringList;
begin
 
Mail := TStringList.Create;
 
try
   
Mail.values['to'] := 'почтовый@адрес';
   
Mail.values['subject'] := 'Тема письма';
   
Mail.values['body'] := 'Любой текст письма';
   
Mail.values['attachment0'] := 'Путь к файлу';
    sendEMail
(Application.Handle, Mail);
 
finally
   
Mail.Free;
 
end;
end;

 

Взято из https://forum.sources.ru

Автор: Rouse_