Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[3.128.199.88] |
|
Сообщ.
#1
,
|
|
|
Cущствуют следующие возможности:
1) Вызвать почтовую программу по умолчанию с заполненными полями 2) Использовать MAPI3) Использовать SMTP - там все просто 4) Использовать COM интерфейс Outlook - там тоже все просто, я даже постил где-то пример 5) Писать свой SMTP Relay сервер и отсылать email напрямую, минуя любые сервера. Для Дельфи6/Дельфи7/Kylix3 можно использовать компоненты Indy (входят в поставку Дельфи) - пример внизу, а так же можно использовать для любых версий Delphi/Kylix компоненты из пакета ICS - Internet component suite. |
Сообщ.
#2
,
|
|
|
Работа через MAPI
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. |
Сообщ.
#3
,
|
|
|
Пример работы с SMTP:
Примечание - работать будет в Дельфи 4-6, для Дельфи 7 надо доустановить компоненты NetMaster 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; {set default values, some of them comes from "Setup" form} 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; (*Mon, 27 Nov 2000 12:37:46 -0700*) 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('nevzorov@yahoo.com', '', '', '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 |
Сообщ.
#4
,
|
|
|
А вот пример автозаполнения формы для нового письма в почтовой программе установленной по умолчанию:
uses shellapi; ... procedure TForm1.Button1Click(Sender: TObject); begin shellexecute(handle, 'Open', 'mailto:somebody@yahoo.com?subject=Regarding your advice&Body=First%20Line%0D%0ASecond%20line&CC=somebodyelse@hotmail.com', nil, nil, sw_restore); end; Немного пояснений: 1) Пробелы в тексте желательно заполнять сочетанием %20 2) Конец строки обозначать как %0D%0A 3) Поля отделять друг от друга символом & |
Сообщ.
#5
,
|
|
|
Пример отсылки письма используя 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; |
Сообщ.
#6
,
|
|
|
Использование 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 |