📄 smtpprot.pas
字号:
{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Fran鏾is PIETTE
Object: TSmtpCli class implements the SMTP protocol (RFC-821)
Support file attachement using MIME format (RFC-1521)
Creation: 09 october 1997
Version: 2.17
EMail: http://users.swing.be/francois.piette francois.piette@swing.be
http://www.rtfm.be/fpiette francois.piette@rtfm.be
francois.piette@pophost.eunet.be
Support: Use the mailing list twsocket@rtfm.be See website for details.
Legal issues: Copyright (C) 1997-2000 by Fran鏾is PIETTE
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
<francois.piette@pophost.eunet.be>
This software is provided 'as-is', without any express or
implied warranty. In no event will the author be held liable
for any damages arising from the use of this software.
Permission is granted to anyone to use this software for any
purpose, including commercial applications, and to alter it
and redistribute it freely, subject to the following
restrictions:
1. The origin of this software must not be misrepresented,
you must not claim that you wrote the original software.
If you use this software in a product, an acknowledgment
in the product documentation would be appreciated but is
not required.
2. Altered source versions must be plainly marked as such, and
must not be misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
4. You must register this software by sending a picture postcard
to the author. Use a nice stamp and mention your name, street
address, EMail address and any comment you like to say.
Updates:
Oct 25, 1997 Added the OnHeaderLine event to allow modification/deletion of
header lines.
Oct 26, 1997 V1.00 Released
Changed the OnGetData event arguments to have code compatible
between 16 and 32 bit versions (replaced string with PChar).
Jan 10, 1998 V1.01 Added a Port property
Feb 14, 1998 V1.02 Added an intermeditae TCustomSmtpClient in order to
support MIME in the TSmtpCli. I implemented MIME with the
help of code donated by Brad Choate <choate@delphiexchange.com>
Mime is used for file attachement.
Added a SetRcptName to copy values from a string list in place
of copying the string list reference.
Feb 15, 1998 V1.03 Added a CharSet property, defaulting to iso-8859-1
Mar 02, 1998 V1.04 Corrected result for QUIT command.
Marcus Schmutz <schmutz@kwsoft.de>
Mar 06, 1998 V1.05 Use OnDataSent event to prenvent over-buffering
Mar 15, 1998 V1.06 Implemented the Date header line
Apr 01, 1998 V1.07 Adapted for BCB V3
Apr 10, 1998 V1.08 Corrected DayNames: sunday is day 1, saturday is day 7.
Changed UUEncode procedures to virtual methods to ease component
inheritance.
Apr 26, 1998 V1.09 Ignore any empty file name (a very common error !)
Check if file exists and raise an exception if not.
Made Rfc822DateTime public.
Added Rset method from Victor Garcia Aprea <vga@overnet.com.ar>
Added Abort procedure to close the socket and abort any operation
Made the underlaying TWSocket accessible using a property.
Apr 28, 1998 V1.10 Reset FTimeOutFlag in the mail procedure.
May 05, 1998 V1.11 Handled correctly lines beginning with a dot.
May 21, 1998 V1.12 Check for nil argument in SetEMailFiles
Added OnCommand and OnResponse events.
Added SendDataLine procedure (same as SendCommand, but do not
trigger OnCommand event) used for header and message lines.
Jul 29, 1998 V2.00 Asynchronous functions and new TSyncSmtpCli component
to be a placer holder for synchronous version.
Renamed source file from SmtpCli to SmtpProt.
Aug 06, 1998 V2.01 Made HighLevelAsync public and added smtpCustom to be used
for custom calls to HighLevelAsync.
Sep 22, 1998 V2.02 Removed useless Wait unit from the uses clause.
Oct 04, 1998 V2.03 Checked for Error in TriggerRequestDone.
Oct 11, 1998 V2.04 Removed -1 in DataNext. Thanks to Dennis V. Turov
<chip@quorum.ru> for finding this bug.
Nov 22, 1998 V2.05 Implemented VRFY command with code proposed by
DZ-Jay <dz@caribe.net> but use HdrTo property as name to verify.
Nov 29, 1998 V2.06 Added SetErrorMessage in WSocketSessionConnected when an
error occured. Thanks to DZ-Jay.
Changed FMimeBoundary format to use numbered month instead of
month names. Thanks to Dmitry Kislov <kislov@tekom.odessa.ua> who
found that some foreign charsets are invalid in mime boundaries.
Dec 22, 1998 V2.07 Handle exception when connecting (will be triggered when
an invalid port has been given).
Force readonly when reading attached files.
Added ContentType property as suggested by Henri Fournier
<hfournier@home.com>
Feb 13, 1999 V2.08 Published the state property and OnSessionConnected,
OnSessionClosed events.
Feb 27, 1999 V2.09 Added Connected property.
Added code from Larry Pesyna <ldpesyna@aep.com> to handle time
zone bias.
Added OnAttachContentType event. Thanks to Vladimir M.
Zakharychev <zak@dzbjaro.bertelsmann.de> for his suggestion.
Added ReplyTo and ReturnPath properties. Thanks to Eric Bullen
<eric@thedeepsky.com> for his code.
Mar 06, 1999 V2.10 Conditional compile to remove timezone code unsupported by
Delphi 1.
Mar 09, 1999 V2.11 Made state property [really] published.
Mar 27, 1999 V2.12 Published OnProcessHeader
Changed sign for time zone bias (thanks to Larry Pesyna).
May 10, 1999 V2.13 'daylight' functionality for timezonebias function.
Thanks to Bernhard Goebel <Bernhard.Goebel@t-online.de>
Do not set FRequestType in Connect when called from HighLevel
function. Thanks to Eugene V. Krapivin <evk@tagil.ru>.
May 18, 1999 V2.14 Added Sender field. If ommited, the sender is becomes
HdrFrom. Jon Glazer <jglazer@adconn.com>
Jul 30, 1999 V2.15 Added MailMessage property by Thomas Kvamme
<thokvamm@online.no>. MailMessage property can be used with
OnGetData event. If both are used, MailMessages lines appears
before lines got by OnGetData.
Oct 02, 1999 V2.16 Added OnAttachHeader event as suggested by Vladimir M.
Zakharychev <zak@dzbjaro.bertelsmann.de>
Accept friendly EMail addresses. Thanks to Thierry De Leeuw
<thierry.deleeuw@proxis.be> for his code.
Nov 01, 1999 V2.17 Made all fields protected to easy component inheritance.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit SmtpProt;
interface
{$B-} { Enable partial boolean evaluation }
{$T-} { Untyped pointers }
{$X+} { Enable extended syntax }
{$IFNDEF VER80} { Not for Delphi 1 }
{$H+} { Use long strings }
{$J+} { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0 }
{$ObjExportAll On}
{$ENDIF}
{$IFDEF VER125} { C++ Builder V4.0 }
{$ObjExportAll On}
{$ENDIF}
uses
WinTypes, WinProcs, SysUtils, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus, WSocket, WinSock;
const
SmtpCliVersion = 217;
CopyRight : String = ' SMTP component (c) 1997-2000 F. Piette V2.17 ';
{$IFDEF VER80}
{ Delphi 1 has a 255 characters string limitation }
SMTP_RCV_BUF_SIZE = 255;
{$ELSE}
SMTP_RCV_BUF_SIZE = 4096;
{$ENDIF}
WM_SMTP_REQUEST_DONE = WM_USER + 1;
type
SmtpException = class(Exception);
TSmtpState = (smtpReady, smtpDnsLookup, smtpConnecting,
smtpConnected, smtpInternalReady,
smtpWaitingBanner, smtpWaitingResponse, smtpAbort);
TSmtpRequest = (smtpConnect, smtpHelo, smtpMailFrom, smtpVrfy,
smtpRcptTo, smtpData, smtpQuit,
smtpRset, smtpOpen, smtpMail, smtpCustom);
TSmtpFct = (smtpFctNone, smtpFctHelo, smtpFctConnect,
smtpFctMailFrom, smtpFctRcptTo, smtpFctData,
smtpFctVrfy, smtpFctQuit, smtpFctRset);
TSmtpFctSet = set of TSmtpFct;
TSmtpContentType = (smtpHTML, smtpPlainText);
TSmtpDisplay = procedure(Sender : TObject;
Msg : String) of object;
TSmtpHeaderLineEvent = procedure(Sender : TObject;
Msg : PChar;
Size : Integer) of object;
TSmtpProcessHeaderEvent = procedure(Sender : TObject;
HdrLines : TStrings) of object;
TSmtpGetDataEvent = procedure(Sender : TObject;
LineNum : Integer;
MsgLine : PChar;
MaxLen : Integer;
var More: Boolean) of object;
TSmtpRequestDone = procedure(Sender : TObject;
RqType : TSmtpRequest;
Error : Word) of object;
TSmtpAttachmentContentType = procedure(Sender : TObject;
FileNumber : Integer;
var FileName : String;
var ContentType : String) of object;
TSmtpAttachHeader = procedure(Sender : TObject;
FileNumber : Integer;
FileName : String;
HdrLines : TStrings) of object;
TSmtpNextProc = procedure of object;
{ Base component, implementing the transport, without MIME support }
TCustomSmtpClient = class(TComponent)
protected
FWSocket : TWSocket; { Underlaying socket }
FHost : String; { SMTP server hostname or IP }
FPort : String; { Should be 'smtp' }
FSignOn : String; { Used for the 'HELO' command }
FFromName : String; { Sender's EMail }
FRcptName : TStrings; { Recepients EMails list }
FMailMessage : TStrings;
FHdrFrom : String;
FHdrTo : String;
FHdrReplyTo : String;
FHdrReturnPath : String;
FHdrSubject : String;
FHdrSender : String; { Mail Sender's Email }
FState : TSmtpState;
FCharSet : String;
FContentType : TSmtpContentType;
FContentTypeStr : String;
FLastResponse : String;
FErrorMessage : String;
FTag : LongInt;
FConnected : Boolean;
FRequestType : TSmtpRequest;
FRequestDoneFlag : Boolean;
FReceiveLen : Integer;
FRequestResult : Integer;
FStatusCode : Integer;
FReceiveBuffer : array [0..SMTP_RCV_BUF_SIZE - 1] of char;
FNext : TSmtpNextProc;
FWhenConnected : TSmtpNextProc;
FFctSet : TSmtpFctSet;
FFctPrv : TSmtpFct;
FHighLevelResult : Integer;
FHighLevelFlag : Boolean;
FNextRequest : TSmtpNextProc;
FLastResponseSave : String;
FStatusCodeSave : Integer;
FRestartFlag : Boolean;
FOkResponses : array [0..15] of Integer;
FDoneAsync : TSmtpNextProc;
FWindowHandle : HWND;
FItemCount : LongInt;
FHdrLines : TStrings;
FLineNum : Integer;
FMoreLines : Boolean;
FOnDisplay : TSmtpDisplay;
FOnCommand : TSmtpDisplay;
FOnResponse : TSmtpDisplay;
FOnGetData : TSmtpGetDataEvent;
FOnHeaderLine : TSmtpHeaderLineEvent;
FOnProcessHeader : TSmtpProcessHeaderEvent;
FOnRequestDone : TSmtpRequestDone;
FOnStateChange : TNotifyEvent;
FOnSessionConnected : TSessionConnected;
FOnSessionClosed : TSessionClosed;
procedure TriggerDisplay(Msg : String); virtual;
procedure TriggerCommand(Msg : String); virtual;
procedure TriggerResponse(Msg : String); virtual;
procedure TriggerRequestDone(Error: Word); virtual;
procedure TriggerStateChange; virtual;
procedure TriggerGetData(LineNum : Integer;
MsgLine : PChar;
MaxLen : Integer;
var More : Boolean); virtual;
procedure TriggerHeaderLine(Line : PChar; Size : Integer); virtual;
procedure TriggerProcessHeader(HdrLines : TStrings); virtual;
procedure TriggerSessionConnected(Error : Word); virtual;
procedure TriggerSessionClosed(Error : Word); virtual;
procedure ClearErrorMessage;
procedure SetErrorMessage;
procedure StateChange(NewState : TSmtpState);
procedure SendCommand(Cmd : String); virtual;
procedure SetRcptName(newValue : TStrings);
procedure SetMailMessage(newValue : TStrings);
procedure InitUUEncode(var hFile: File; sFile: string); virtual;
procedure DoUUEncode(var hFile: File; var sLine: string; var More: boolean); virtual;
procedure EndUUEncode(var hFile: File); virtual;
procedure CheckReady;
procedure WSocketDnsLookupDone(Sender: TObject; Error: Word);
procedure WSocketSessionConnected(Sender: TObject; Error: Word);
procedure WSocketDataAvailable(Sender: TObject; Error: Word);
procedure WSocketDataSent(Sender : TObject; Error : Word);
procedure WSocketSessionClosed(Sender : TObject; Error : WORD);
procedure DisplayLastResponse;
procedure DoHighLevelAsync;
procedure ExecAsync(RqType : TSmtpRequest;
Cmd : String;
OkResponses : array of Word;
DoneAsync : TSmtpNextProc);
procedure NextExecAsync;
procedure RcptToNext;
procedure RcptToDone;
procedure DataNext;
procedure WndProc(var MsgRec: TMessage); virtual;
procedure WMSmtpRequestDone(var msg: TMessage);
message WM_SMTP_REQUEST_DONE;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Connect; virtual; { Connect to the mail server }
procedure Helo; virtual; { Send the HELO command }
procedure Vrfy; virtual; { Send the VRFY command }
procedure MailFrom; virtual; { Send the MAILFROM command }
procedure RcptTo; virtual; { Send RECPTTO command }
procedure Data; virtual; { Send DATA command }
procedure Quit; virtual; { Send QUITE command, close }
procedure Rset; virtual; { Send RSET command }
procedure Abort; virtual; { Abort opertaion, close }
procedure Open; virtual; { Connect, Helo }
procedure Mail; virtual; { MailFrom, RcptTo, Data }
property WSocket : TWSocket read FWSocket;
property Handle : HWND read FWindowHandle;
property Connected : Boolean read FConnected;
procedure HighLevelAsync(RqType : TSmtpRequest; Fcts : TSmtpFctSet);
procedure SetContentType(newValue : TSmtpContentType);
protected
property Host : String read FHost
write FHost;
property Port : String read FPort
write FPort;
property SignOn : String read FSignOn
write FSignOn;
property FromName : String read FFromName
write FFromName;
property RcptName : TStrings read FRcptName
write SetRcptName;
property MailMessage : TStrings read FMailMessage
write SetMailMessage;
property HdrFrom : String read FHdrFrom
write FHdrFrom;
property HdrTo : String read FHdrTo
write FHdrTo;
property HdrReplyTo : String read FHdrReplyTo
write FHdrReplyTo;
property HdrReturnPath : String read FHdrReturnPath
write FHdrReturnPath;
property HdrSubject : String read FHdrSubject
write FHdrSubject;
property HdrSender: String read FHdrSender
write FHdrSender;
property CharSet : String read FCharSet
write FCharSet;
property ContentType : TSmtpContentType read FContentType
write SetContentType;
property ErrorMessage : String read FErrorMessage;
property LastResponse : String read FLastResponse;
property State : TSmtpState read FState;
property Tag : LongInt read FTag
write FTag;
property OnDisplay : TSmtpDisplay read FOnDisplay
write FOnDisplay;
property OnCommand: TSmtpDisplay read FOnCommand
write FOnCommand;
property OnResponse: TSmtpDisplay read FOnResponse
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -