Отправка e-mail
| Автор
| Сообщение |
|
|
|
Цитата |
|
| Как из программы отправить мне на e-mail письмо, содержащие какие-либо данные. Пишу на Дельфи 6. |
|
| В начало |
|
 |
|
|
 |
 orlov_ds
Модератор
Возраст: 31
Знак зодиака: 
Зарегистрирован: 14.04.2004
Сообщения: 1723
Откуда: Новосибирск
|
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака: 
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
Cущствуют следующие возможности:
1) Вызвать почтовую программу по умолчанию с заполненными полями - не позволяет автоматизировать работу, не позволяет постать письмо с аттачментом, но исключительно удобно в окнах About.
2) Использовать MAPI - несколько устаревший способ, но вполне работоспособный
3) Использовать SMTP - там все просто, однако посыка не напрямую, требуется наличие SMTP сервера, например сервера провайдера.
4) Использовать COM интерфейс Outlook - там тоже все просто, но нужно наличие установленного и полностью подключенного Outlook
5) Писать свой SMTP Relay сервер и отсылать email напрямую, минуя любые сервера. Для Дельфи6/Дельфи7/Kylix3 можно использовать компоненты Indy (входят в поставку Дельфи) - пример внизу, а так же можно использовать для любых версий Delphi/Kylix компоненты из пакета ICS - Internet component suite.
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака:
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
----------------------------1------------------------------
А вот пример автозаполнения формы для нового письма в почтовой программе установленной по умолчанию:
uses shellapi;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
shellexecute(handle,
'Open',
'mailto:vit@vingrad.ru?subject=Regarding your advice&Body=First%20Line%0D%0ASecond%20line&CC=somebodyelse@vingrad.ru',
nil, nil, sw_restore);
end;
Немного пояснений:
1) Пробелы в тексте желательно заполнять сочетанием %20
2) Конец строки обозначать как %0D%0A
3) Поля отделять друг от друга символом &
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака:
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
----------------------------2------------------------------
Работа через 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
ulRecerved:= 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.
---------------------ИЛИ---------------------
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.
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака:
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
-------------------------3---------------------------
Пример работы с SMTP
В следующем примере E-mail отправляется автоматически сразу после нажатия кнопки.
ЗАМЕЧАНИЕ: Вам потребуется компонент 'TNMSMTP'. Этот компонент входит в поставляется с Delphi 4 и 5 и его можно найти на закладке 'Fastnet'.
procedure TForm1.Button1Click(Sender: TObject);
begin
NMSMTP1.Host := 'smtp.mailserver.com';
NMSMTP1.UserID := 'h.abdullah';
NMSMTP1.Connect;
NMSMTP1.PostMessage.FromAddress := 'hasan@excite.com';
NMSMTP1.PostMessage.ToAddress.Text := 'someone@xmail.com';
NMSMTP1.PostMessage.Body.Text := 'Текст письма';
NMSMTP1.PostMessage.Subject := 'Тема письма';
NMSMTP1.SendMail;
end;
------------------------------ИЛИ-------------------------------
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, Psock, NMsmtp;
type
TForm1 = class(TForm)
Memo: TRichEdit;
Panel1: TPanel;
SMTP: TNMSMTP;
Panel2: TPanel;
FromAddress: TEdit;
predefined: TLabel;
FromName: TEdit;
Subject: TEdit;
LocalProgram: TEdit;
ReplyTo: TEdit;
islog: TCheckBox;
Host: TEdit;
Port: TEdit;
userid: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
Procedure CleanContext;
procedure PerformConnection;
procedure AddMessage(msg:string; color:integer);
procedure log(inpt :string);
Procedure SetSMTP;
public
function SendEmail(_to, cc, bcc, Subject, body, attachment:string; HTMLFormat:boolean):boolean;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
Procedure TForm1.SetSMTP;
begin
SMTP.Host:=Host.Text;
SMTP.Port:=strtoint(Port.text);
SMTP.UserID:=userid.text;
end;
Function GetEmailDateTime:string;
var tz:_time_Zone_information;
s:string;
begin
GetTimeZoneInformation(tz);
if (tz.Bias*100 div 60)<1000 then
s:=format(' -0%d',[tz.Bias*100 div 60])
else
s:=format(' -%d',[tz.Bias*100 div 60]);
result:=formatdatetime('ddd, dd mmm yyyy hh:nn:ss',now)+s;
end;
Procedure TForm1.CleanContext;
begin
SMTP.PostMessage.FromAddress:=FromAddress.text;
SMTP.PostMessage.FromName:=FromName.text;
SMTP.PostMessage.ToAddress.Clear;
SMTP.PostMessage.ToCarbonCopy.clear;
SMTP.PostMessage.ToBlindCarbonCopy.clear;
SMTP.PostMessage.Body.clear;
SMTP.PostMessage.Attachments.clear;
SMTP.PostMessage.Subject:=Subject.text;
SMTP.PostMessage.LocalProgram:=LocalProgram.text;
SMTP.PostMessage.Date:=GetEmailDateTime;
SMTP.PostMessage.ReplyTo:=ReplyTo.Text;
end;
procedure TForm1.log(inpt :string);
var outf:textfile;
begin {writing in the log file}
if not islog.checked then exit;
assignfile(outf, changefileext(paramstr(0), '.log'));
if fileexists(changefileext(paramstr(0), '.log')) then
append(outf)
else
rewrite(outf);
writeln(outf, datetimetostr(now)+'|'+inpt);
closefile(outf);
end;
procedure TForm1.AddMessage(msg:string; color:integer);
begin {showing in the memo field progress...}
while memo.lines.Count>2000 do memo.lines.Delete(0);
memo.sellength:=0;
memo.selstart:=length(memo.text);
memo.selattributes.Color:=Color;
memo.seltext:=#13#10+DateTimeTostr(now)+' '+msg;
memo.perform($00B7,0,0);
Application.ProcessMessages;
if color<>clRed then log(DateTimeTostr(now)+' '+msg) else log('Error: '+DateTimeTostr(now)+' '+msg);
end;
procedure TForm1.PerformConnection;
begin
while (not SMTP.connected) do
begin
SetSMTP;
AddMessage('Connecting to SMTP',clBlue);
application.processmessages;
try
SMTP.Connect;
AddMessage('No Errors',clBlue);
except
on e:exception do AddMessage('Error conection: '+e.message,clBlue);
end;
end;
end;
Function TForm1.SendEmail(_to, cc, bcc, Subject, body, attachment:string; HTMLFormat:boolean):boolean;
begin
PerformConnection;
result:=true;
CleanContext;
try
if (attachment<>'') and (not Fileexists(attachment)) then
begin
AddMessage('Attachment is not ready yet ('+ attachment+') ', clNavy);
sleep(300);
result:=false;
exit;
end;
SMTP.PostMessage.ToAddress.text:=StringReplace(_to, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if cc<>'' then SMTP.PostMessage.ToCarbonCopy.text:=StringReplace(cc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if bcc<>'' then SMTP.PostMessage.ToBlindCarbonCopy.text:=StringReplace(bcc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if Subject<>'' then SMTP.PostMessage.Subject:=Subject;
if HTMLFormat then SMTP.SubType:=mtPlain else SMTP.SubType:=mtHtml;
SMTP.PostMessage.Body.Text:=Body;
if attachment<>'' then SMTP.PostMessage.Attachments.add(attachment);
AddMessage('Sending to '+ _to, clGreen);
SMTP.SendMail;
AddMessage('Complete.'+#13#10, clGreen);
except
on e:sysutils.exception do
begin
AddMessage(e.message, clRed);
result:=false;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendEmail('vit@vingrad.ru', '', '', 'test', 'body', '', False);
end;
end.
А это форма для этого примера:
object Form1: TForm1
Left = 278
Top = 108
Width = 539
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo: TRichEdit
Left = 0
Top = 0
Width = 346
Height = 420
Align = alClient
Lines.Strings = ('Memo')
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 420
Width = 531
Height = 33
Align = alBottom
Caption = 'Panel1'
TabOrder = 1
object Button1: TButton
Left = 440
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
object Panel2: TPanel
Left = 346
Top = 0
Width = 185
Height = 420
Align = alRight
Caption = 'Panel2'
TabOrder = 2
object predefined: TLabel
Left = 8
Top = 8
Width = 87
Height = 13
Caption = 'predefined values:'
end
object FromAddress: TEdit
Left = 24
Top = 32
Width = 121
Height = 21
TabOrder = 0
Text = 'FromAddress'
end
object FromName: TEdit
Left = 24
Top = 56
Width = 121
Height = 21
TabOrder = 1
Text = 'FromName'
end
object Subject: TEdit
Left = 24
Top = 80
Width = 121
Height = 21
TabOrder = 2
Text = 'Subject'
end
object LocalProgram: TEdit
Left = 24
Top = 104
Width = 121
Height = 21
TabOrder = 3
Text = 'LocalProgram'
end
object ReplyTo: TEdit
Left = 24
Top = 128
Width = 121
Height = 21
TabOrder = 4
Text = 'ReplyTo'
end
object islog: TCheckBox
Left = 32
Top = 168
Width = 97
Height = 17
Caption = 'islog'
TabOrder = 5
end
object Host: TEdit
Left = 24
Top = 240
Width = 121
Height = 21
TabOrder = 6
Text = 'Host'
end
object Port: TEdit
Left = 24
Top = 264
Width = 121
Height = 21
TabOrder = 7
Text = 'Port'
end
object userid: TEdit
Left = 24
Top = 288
Width = 121
Height = 21
TabOrder = 8
Text = 'userid'
end
end
object SMTP: TNMSMTP
Port = 25
ReportLevel = 0
EncodeType = uuMime
ClearParams = True
SubType = mtPlain
Charset = 'us-ascii'
Left = 296
Top = 32
end
end
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака:
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
---------------------------4-------------------------
Использование COM объекта Outlook
Пример отсылки письма используя COM объект Outlook
uses Outlook_TLB;
var outlook : _application;
Procedure Init;
begin
outlook := Coapplication_.Create;
end;
procedure SendEmail;
begin
with Outlook.CreateItem(olMailItem) as mailitem do
begin
To_ := 'email@email.com';
cc:='email2@email.com';
Subject := 'This is subject line';
Attachments.Add('FileName',1,1,'This is attachment');
Body :='This is email body';
Send;
end;
end;
--------------------ИЛИ-------------------------
uses ComObj;
procedure TForm1.Button1Click(Sender: TObject);
Const
// константы OlItemType
olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// константы OlAttachmentType
olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
var
myOlApp, myItem, myRecipient, myAttachments: OleVariant;
begin
// файл VBScript для создания почтового сообщения и прикрепления к нему файла
myOlApp := CreateOLEObject('Outlook.Application');
myItem := myOlApp.CreateItem(olMailItem);
myItem.Subject := 'This is the Subject';
myRecipient := myItem.Recipients.Add('recipientaddress@recipienthost.com');
myItem.Body := #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + 'Hello,' + #13;
myItem.Body := myItem.Body + 'This code created this message and '+
' sent it and I didn''t even have' + #13;
myItem.Body := myItem.Body + 'to click the send button!!!' + #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + 'If you have any more problems, let me know' +
#13;
myItem.Body := myItem.Body + 'rename to blah.vbs and run like this:' + #13;
myItem.Body := myItem.Body + 'wscript c:\blah.vbs' + #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + 'Eddie' + #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + 'const'+ #13;
myItem.Body := myItem.Body + ' // константы OlItemType'+ #13;
myItem.Body := myItem.Body + ' olMailItem = 0;'+ #13;
myItem.Body := myItem.Body + ' olAppointmentItem = 1;'+ #13;
myItem.Body := myItem.Body + ' olContactItem = 2;'+ #13;
myItem.Body := myItem.Body + ' olTaskItem = 3;'+ #13;
myItem.Body := myItem.Body + ' olJournalItem = 4;'+ #13;
myItem.Body := myItem.Body + ' olNoteItem = 5;'+ #13;
myItem.Body := myItem.Body + ' olPostItem = 6;'+ #13;
myItem.Body := myItem.Body + ' // OlAttachmentType constants'+ #13;
myItem.Body := myItem.Body + ' olByValue = 1;'+ #13;
myItem.Body := myItem.Body + ' olByReference = 4;'+ #13;
myItem.Body := myItem.Body + ' olEmbeddedItem = 5;'+ #13;
myItem.Body := myItem.Body + ' olOLE = 6;'+ #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + 'var'+ #13;
myItem.Body := myItem.Body + ' myOlApp, myItem, myRecipient, myAttachments:
OleVariant;'+ #13;
myItem.Body := myItem.Body + 'begin'+ #13;
myItem.Body := myItem.Body + ' myOlApp :=
CreateObject(''Outlook.Application'')' + #13;
myItem.Body := myItem.Body + ' myItem := myOlApp.CreateItem(olMailItem)' +
#13;
myItem.Body := myItem.Body + ' myItem.Subject := ''This is the Subject''' +
#13;
myItem.Body := myItem.Body + ' myItem.Body := ''This is the body''' + #13;
myItem.Body := myItem.Body + ' myRecipient := myItem.Recipients.Add
('recipientaddress@recipienthost.com')' + #13;
myItem.Body := myItem.Body + ' myAttachments := myItem.Attachments' + #13;
myItem.Body := myItem.Body + ' // Теперь прикрепим файлы...' + #13;
myItem.Body := myItem.Body + ' myAttachments.Add ''C:\blah.txt'', olByValue,
1, ''Blah.txt Attachment''' + #13;
myItem.Body := myItem.Body + ' myItem.Send' + #13;
myItem.Body := myItem.Body + ' myOlApp := VarNull;' + #13;
myItem.Body := myItem.Body + ' myItem := VarNull;' + #13;
myItem.Body := myItem.Body + ' myRecipient := VarNull;' + #13;
myItem.Body := myItem.Body + ' myAttachments := VarNull;' + #13;
myItem.Body := myItem.Body + 'end;' + #13;
// Теперь прикрепим файлы...
myAttachments := myItem.Attachments;
myAttachments.Add('C:\blah.txt', olByValue, 1, 'Blah.txt Attachment');
myItem.Send
myOlApp := VarNull;
myItem := VarNull;
myRecipient := VarNull;
myAttachments := VarNull;
End;
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
Essentuki
Энтузиаст
Возраст: 27
Знак зодиака:
Зарегистрирован: 14.09.2005
Сообщения: 369
Откуда: г Иркутск
|
|
|
Цитата |
|
---------------------5-----------------------
Использование SMTP Relay Server
Использование SMTP Relay Server - отсылка письма напрямую минуя любые промежуточные сервера (пример взят из библиотеки Indy). Для отсылки письма с использованием компонентов Indy. Пример для Delphi 7 (скорее всего будет работать и в Delphi 6), для Kylix 3 нужны небольшие исправления для перевода в CLX приложение (сама функциональность та же).
Пример модуля:
unit fMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdComponent,
IdUDPBase, IdUDPClient, IdDNSResolver, IdBaseComponent, IdMessage,
StdCtrls, ExtCtrls, ComCtrls, IdAntiFreezeBase, IdAntiFreeze;
type
TfrmMain = class(TForm)
IdMessage: TIdMessage;
IdDNSResolver: TIdDNSResolver;
IdSMTP: TIdSMTP;
Label1: TLabel;
sbMain: TStatusBar;
Label2: TLabel;
edtDNS: TEdit;
Label3: TLabel;
Label4: TLabel;
edtSender: TEdit;
Label5: TLabel;
edtRecipient: TEdit;
Label6: TLabel;
edtSubject: TEdit;
Label7: TLabel;
mmoMessageText: TMemo;
btnSendMail: TButton;
btnExit: TButton;
IdAntiFreeze: TIdAntiFreeze;
Label8: TLabel;
edtTimeOut: TEdit;
Label9: TLabel;
Label10: TLabel;
procedure btnExitClick(Sender: TObject);
procedure btnSendMailClick(Sender: TObject);
public
fMailServers : TStringList;
Function PadZero(s:String):String;
Function GetMailServers:Boolean;
Function ValidData : Boolean;
Procedure SendMail; OverLoad;
Function SendMail(aHost : String):Boolean; OverLoad;
Procedure LockControls;
procedure UnlockControls;
Procedure Msg(aMessage:String);
end;
var
frmMain: TfrmMain;
implementation
{$R *.DFM}
procedure TfrmMain.btnExitClick(Sender: TObject);
begin
application.terminate;
end;
procedure TfrmMain.btnSendMailClick(Sender: TObject);
begin
Msg('');
LockControls;
if ValidData then SendMail;
UnlockControls;
Msg('');
end;
function TfrmMain.GetMailServers: Boolean;
var
i,x : integer;
LDomainPart : String;
LMXRecord : TMXRecord;
begin
if not assigned(fmailServers) then fMailServers := TStringList.Create;
fmailServers.clear;
Result := true;
with IdDNSResolver do
begin
QueryResult.Clear;
QueryRecords := [qtMX];
Msg('Setting up DNS query parameters');
Host := edtDNS.text;
ReceiveTimeout := StrToInt(edtTimeOut.text);
// Extract the domain part from recipient email address
LDomainPart := copy(edtRecipient.text,pos('@',edtRecipient.text)+1,length(edtRecipient.text));
// the domain name to resolve
try
Msg('Resolving DNS');
Resolve(LDomainPart);
if QueryResult.Count > 0 then
begin
for i := 0 to QueryResult.Count - 1 do
begin
LMXRecord := TMXRecord(QueryResult.Items[i]);
fMailServers.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
end;
// sort in order of priority and then remove extra data
fMailServers.Sorted := false;
for i := 0 to fMailServers.count - 1 do
begin
x := pos('=',fMailServers.Strings[i]);
if x > 0 then fMailServers.Strings[i] :=
copy(fMailServers.Strings[i],x+1,length(fMailServers.Strings[i]));
end;
fMailServers.Sorted := true;
fMailServers.Duplicates := dupIgnore;
Result := true;
end
else
begin
Msg('No response from DNS server');
MessageDlg('There is no response from the DNS server !', mtInformation, [mbOK], 0);
Result := false;
end;
except
on E : Exception do
begin
Msg('Error resolving domain');
MessageDlg('Error resolving domain: ' + e.message, mtInformation, [mbOK], 0);
Result := false;
end;
end;
end;
end;
// Used in DNS preferance sorting
procedure TfrmMain.LockControls;
var i : integer;
begin
edtDNS.enabled := false;
edtSender.enabled := false;
edtRecipient.enabled := false;
edtSubject.enabled := false;
mmoMessageText.enabled := false;
btnExit.enabled := false;
btnSendMail.enabled := false;
end;
procedure TfrmMain.UnlockControls;
begin
edtDNS.enabled := true;
edtSender.enabled := true;
edtRecipient.enabled := true;
edtSubject.enabled := true;
mmoMessageText.enabled := true;
btnExit.enabled := true;
btnSendMail.enabled := true;
end;
function TfrmMain.PadZero(s: String): String;
begin
if length(s) < 2 then s := '0' + s;
Result := s;
end;
procedure TfrmMain.SendMail;
var i : integer;
begin
if GetMailServers then
begin
with IdMessage do
begin
Msg('Assigning mail message properties');
From.Text := edtSender.text;
Sender.Text := edtSender.text;
Recipients.EMailAddresses := edtRecipient.text;
Subject := edtSubject.text;
Body := mmoMessageText.Lines;
end;
for i := 0 to fMailServers.count -1 do
begin
Msg('Attempting to send mail');
if SendMail(fMailServers.Strings[i]) then
begin
MessageDlg('Mail successfully sent and available for pickup by recipient !',
mtInformation, [mbOK], 0);
Exit;
end;
end;
// if we are here then something went wrong .. ie there were no available servers to accept our mail!
MessageDlg('Could not send mail to remote server - please try again later.', mtInformation, [mbOK], 0);
end;
if assigned(fMailServers) then FreeAndNil(fMailServers);
end;
function TfrmMain.SendMail(aHost: String): Boolean;
begin
Result := false;
with IdSMTP do
begin
Caption := 'Trying to sendmail via: ' + aHost;
Msg('Trying to sendmail via: ' + aHost);
Host := aHost;
try
Msg('Attempting connect');
Connect;
Msg('Successful connect ... sending message');
Send(IdMessage);
Msg('Attempting disconnect');
Disconnect;
msg('Successful disconnect');
Result := true;
except on E : Exception do
begin
if connected then try disconnect; except end;
Msg('Error sending message');
result := false;
ShowMessage(E.Message);
end;
end;
end;
Caption := '';
end;
function TfrmMain.ValidData: Boolean;
var ErrString:string;
begin
Result := True;
ErrString := '';
if trim(edtDNS.text) = '' then ErrString := ErrString + #13 + #187 + 'DNS server not filled in';
if trim(edtSender.text) = '' then ErrString := ErrString + #13 + #187 + 'Sender email not filled in';
if trim(edtRecipient.text) = '' then ErrString := ErrString + #13 + #187 + 'Recipient not filled in';
if ErrString <> '' then
begin
MessageDlg('Cannot proceed due to the following errors:'+#13+#10+ ErrString, mtInformation, [mbOK], 0);
Result := False;
end;
end;
procedure TfrmMain.Msg(aMessage: String);
begin
sbMain.SimpleText := aMessage;
application.ProcessMessages;
end;
end.
Форма для модуля:
object frmMain: TfrmMain
Left = 243
Top = 129
Width = 448
Height = 398
Caption = 'INDY - SMTP Relay Demo'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 7
Top = 8
Width = 311
Height = 26
Caption =
'Demonstrates sending mail directly to a users mailbox on a remot' +
'e mailserver - this negates the need for a local SMTP server'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
WordWrap = True
end
object Label2: TLabel
Left = 8
Top = 64
Width = 111
Height = 13
Caption = 'DNS server IP address:'
end
object Label3: TLabel
Left = 8
Top = 123
Width = 104
Height = 13
Caption = 'Sender email address:'
end
object Label4: TLabel
Left = 288
Top = 64
Width = 49
Height = 13
Caption = 'Required !'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label5: TLabel
Left = 8
Top = 150
Width = 115
Height = 13
Caption = 'Recipient email address:'
end
object Label6: TLabel
Left = 8
Top = 177
Width = 72
Height = 13
Caption = 'Subject of mail:'
end
object Label7: TLabel
Left = 8
Top = 204
Width = 66
Height = 13
Caption = 'Message text:'
end
object Label8: TLabel
Left = 8
Top = 91
Width = 95
Height = 13
Caption = 'DNS server timeout:'
end
object Label9: TLabel
Left = 336
Top = 124
Width = 49
Height = 13
Caption = 'Required !'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label10: TLabel
Left = 336
Top = 148
Width = 49
Height = 13
Caption = 'Required !'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object sbMain: TStatusBar
Left = 0
Top = 352
Width = 440
Height = 19
Panels = <>
end
object edtDNS: TEdit
Left = 128
Top = 60
Width = 153
Height = 21
TabOrder = 1
end
object edtSender: TEdit
Left = 128
Top = 119
Width = 205
Height = 21
TabOrder = 2
end
object edtRecipient: TEdit
Left = 128
Top = 146
Width = 205
Height = 21
TabOrder = 3
end
object edtSubject: TEdit
Left = 128
Top = 173
Width = 205
Height = 21
TabOrder = 4
end
object mmoMessageText: TMemo
Left = 128
Top = 200
Width = 205
Height = 113
TabOrder = 5
end
object btnSendMail: TButton
Left = 258
Top = 321
Width = 75
Height = 25
Caption = 'Send mail !'
TabOrder = 6
OnClick = btnSendMailClick
end
object btnExit: TButton
Left = 356
Top = 8
Width = 75
Height = 25
Caption = 'E&xit'
TabOrder = 7
OnClick = btnExitClick
end
object edtTimeOut: TEdit
Left = 128
Top = 87
Width = 61
Height = 21
TabOrder = 8
Text = '5000'
end
object IdMessage: TIdMessage
AttachmentEncoding = 'MIME'
BccList = <>
CCList = <>
Encoding = meMIME
Recipients = <>
ReplyTo = <>
Left = 12
Top = 236
end
object IdDNSResolver: TIdDNSResolver
Port = 53
ReceiveTimeout = 60
QueryRecords = []
Left = 12
Top = 268
end
object IdSMTP: TIdSMTP
MaxLineAction = maException
ReadTimeout = 0
Port = 25
AuthenticationType = atNone
Left = 12
Top = 204
end
object IdAntiFreeze: TIdAntiFreeze
Left = 12
Top = 300
end
end
_________________
Что не убьет нас сделает сильнее... |
|
| В начало |
|
|
orlov_ds
Модератор
Возраст: 31
Знак зодиака:
Зарегистрирован: 14.04.2004
Сообщения: 1723
Откуда: Новосибирск
|
|
|
Цитата |
|
to Esentuki
Короче Склифасовский 
_________________
Хорошо излагает, зараза! Учитесь, Киса! |
|
| В начало |
|
|
|
|
|
Ktf
Администратор
Возраст: 32
Знак зодиака:
Зарегистрирован: 15.05.2005
Сообщения: 1502
Откуда: localhost
|
|
|
Цитата |
|
to Esentuki
ты бы хоть шрифт поменьше поставил
_________________
Пойду посплю перед сном. |
|
| В начало |
|
|
|
|
|
Цитата |
|
to Esentuki
ну них...е . пожалей мой браузер comp |
|
| В начало |
|
|
|
Новая тема
Ответить
Печать
|
Вы можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете голосовать в опросах
Вы не можете присоединять файлы в этом форуме
Вы можете скачивать файлы в этом форуме
|
|
