WEB邮件程序

开发平台：
Delphi

Mailunit.pas：源码内容
							unit Mailunit;
interface
uses
  ComObj, ActiveX, AspTlb, iNotes_TLB, StdVcl,Sysutils,NMSMTP;
type
  TMail = class(TASPObject, IMail)
  protected
    SMTPHost: String;
    SMTPPort: Integer;
    SMTPUser: String;
    SMTPTime: Integer;
    FromAddress: String;
    FromName: String;
    ToAddress: String;
    ToCC: String;
    ToBCC: String;
    Subject: String;
    Body: String;
    Attachments: String;
    MailMsg:String;
    procedure OnEndPage; safecall;
    procedure OnStartPage(const AScriptingContext: IUnknown); safecall;
    function SendMail: OleVariant; safecall;
    function Get_FromAddress: OleVariant; safecall;
    procedure Set_FromAddress(Value: OleVariant); safecall;
    function Get_FromName: OleVariant; safecall;
    procedure Set_FromName(Value: OleVariant); safecall;
    function Get_ToAddress: OleVariant; safecall;
    procedure Set_ToAddress(Value: OleVariant); safecall;
    function Get_ToCC: OleVariant; safecall;
    procedure Set_ToCC(Value: OleVariant); safecall;
    function Get_ToBCC: OleVariant; safecall;
    procedure Set_ToBCC(Value: OleVariant); safecall;
    function Get_Attachments: OleVariant; safecall;
    procedure Set_Attachments(Value: OleVariant); safecall;
    function Get_Body: OleVariant; safecall;
    procedure Set_Body(Value: OleVariant); safecall;
    function Get_Subject: OleVariant; safecall;
    procedure Set_Subject(Value: OleVariant); safecall;
    function Get_SMTPHost: OleVariant; safecall;
    function Get_SMTPPort: SYSINT; safecall;
    procedure Set_SMTPHost(Value: OleVariant); safecall;
    procedure Set_SMTPPort(Value: SYSINT); safecall;
    function Get_SMTPUser: OleVariant; safecall;
    procedure Set_SMTPUser(Value: OleVariant); safecall;
    function Get_SMTPTime: SYSINT; safecall;
    procedure Set_SMTPTime(Value: SYSINT); safecall;
    function CheckAddress(Eaddr:String):Boolean;safecall;
    function CheckMail:Boolean; safecall;
    function Get_Message: OleVariant; safecall;
  end;
implementation
uses ComServ;
procedure TMail.OnEndPage;
begin
  inherited OnEndPage;
end;
procedure TMail.OnStartPage(const AScriptingContext: IUnknown);
begin
  inherited OnStartPage(AScriptingContext);
end;
function TMail.SendMail: OleVariant;
var
  NMSMTP:TNMSMTP;
begin
  if CheckMail then begin
    NMSMTP:=TNMSMTP.Create(nil);
    NMSMTP.Host:=SMTPHost;
    NMSMTP.Port:=SMTPPort;
    NMSMTP.UserID:=SMTPUser;
    NMSMTP.TimeOut:=SMTPTime;
    NMSMTP.PostMessage.FromAddress:=FromAddress;
    NMSMTP.PostMessage.FromName:=FromName;
    NMSMTP.PostMessage.ToAddress.Add(ToAddress);
    NMSMTP.PostMessage.ToCarbonCopy.Add(ToCC);
    NMSMTP.PostMessage.ToBlindCarbonCopy.Add(ToBCC);
    NMSMTP.PostMessage.Subject:=Subject;
    NMSMTP.PostMessage.Body.Text:=Body;
    NMSMTP.PostMessage.Attachments.Text:=Attachments;   
    try
      NMSMTP.Connect ;
      NMSMTP.SendMail;
      MailMsg:='发送邮件成功!';
      Result:=True;
    except
      MailMsg:='发送邮件错误!';
      Result:=False;
    end;
    NMSMTP.Disconnect;
    NMSMTP.Free;
  end
  else begin
    Result:=False;
  end;
end;
function TMail.Get_FromAddress: OleVariant;
begin
  Result:=FromAddress;
end;
procedure TMail.Set_FromAddress(Value: OleVariant);
begin
  FromAddress:=Value;
end;
function TMail.Get_FromName: OleVariant;
begin
  Result:=FromName;
end;
procedure TMail.Set_FromName(Value: OleVariant);
begin
  FromName:=Value;
end;
function TMail.Get_ToAddress: OleVariant;
begin
  Result:=ToAddress;
end;
procedure TMail.Set_ToAddress(Value: OleVariant);
begin
   ToAddress:=Value;
end;
function TMail.Get_ToCC: OleVariant;
begin
   Result:=ToCC;
end;
procedure TMail.Set_ToCC(Value: OleVariant);
begin
   ToCC:=Value;
end;
function TMail.Get_ToBCC: OleVariant;
begin
   Result:=ToBCC;
end;
procedure TMail.Set_ToBCC(Value: OleVariant);
begin
   ToBCC:=Value;
end;
function TMail.Get_Attachments: OleVariant;
begin
   Result:=Attachments;
end;
procedure TMail.Set_Attachments(Value: OleVariant);
begin
  Attachments:=Value;
end;
function TMail.Get_Body: OleVariant;
begin
  Result:=Body;
end;
procedure TMail.Set_Body(Value: OleVariant);
begin
  Body:=Value;
end;
function TMail.Get_Subject: OleVariant;
begin
  Result:=Subject;
end;
procedure TMail.Set_Subject(Value: OleVariant);
begin
  Subject:=Value;
end;
function TMail.Get_SMTPHost: OleVariant;
begin
  Result:=SMTPHost;
end;
function TMail.Get_SMTPPort: SYSINT;
begin
  Result:=SMTPPort;
end;
procedure TMail.Set_SMTPHost(Value: OleVariant);
begin
  SMTPHost:=Value;
end;
procedure TMail.Set_SMTPPort(Value: SYSINT);
begin
  SMTPPort:=Value;
end;
function TMail.Get_SMTPUser: OleVariant;
begin
  Result:=SMTPUser;
end;
procedure TMail.Set_SMTPUser(Value: OleVariant);
begin
  SMTPUser:=Value;
end;
function TMail.Get_SMTPTime: SYSINT;
begin
  Result:=SMTPTime;
end;
procedure TMail.Set_SMTPTime(Value: SYSINT);
begin
  SMTPTime:=Value;
end;
function TMail.CheckMail:Boolean;
begin
  if SMTPHost='' then
  begin
     MailMsg:='发送邮件服务器(SMTP)没找到!';
     Result:=False;
     exit;
  end;
  if FromAddress<>'' then begin
    if not CheckAddress(FromAddress) then begin
       MailMsg:='您的电子邮件地址有错误！';
       Result:=False;
       exit;
    end;
  end
  else begin
      FromAddress:='Unknown';
  end;
  if not CheckAddress(ToAddress) then begin
     MailMsg:='您输入的邮件接收人电子邮件地址有错误！';
     Result:=False;
     exit;
  end;
  if ToCC<>'' then begin
    if not CheckAddress(ToCC) then begin
       MailMsg:='您输入的转送接收人电子邮件地址有错误！';
       Result:=False;
       exit;
    end;
  end;
  if ToBCC<>'' then begin
    if not CheckAddress(ToBCC) then begin
       MailMsg:='您输入的密送接收人电子邮件地址有错误！';
       Result:=False;
       exit;
    end;
  end;
  if Trim(Subject) ='' then Subject:='无主题';
  if Trim(Body) ='' then Body :='无内容';
  Body :=Body+#13#10+#13#10;
  Body :=Body+#13#10+'================================================';
  Body :=Body+#13#10+'          网际备忘中心  世纪倾情奉献            ';
  Body :=Body+#13#10+'            Http://www.ebcall.com               ';
  Body :=Body+#13#10+'================================================';
  Result:=True;
end;
function TMail.CheckAddress(EAddr:String):Boolean;
var
   AtNum:Integer;
   AtEnd:Integer;
   AtCur:Integer;
   CurChr:PChar;
begin
  {Check Address}
   Result:=False;
   AtEnd:=Length(EAddr);
   if AtEnd<=5 then exit;

   for AtCur:=1 to Atend do begin
     CurChr:=PChar(Copy(EAddr,AtCur,1));
     if CurChr[0] in ['~','`','!','#','$','%','^','&','*','(',')','+','=','|',
        '','}','{',']','[','"','''',':',';','<','>',',','?','/'] then
       Exit;
   end;

   AtNum:=Pos('@',EAddr);
   if AtNum in [0,1,AtEnd] then Exit;

   AtNum:=Pos('.',EAddr);
   if AtNum in [0,1,AtEnd] then Exit;

   AtNum:=Pos('@.',EAddr);
   if AtNum <>0 then Exit;

   AtNum:=Pos('.@',EAddr);
   if AtNum <>0 then Exit;

   Result:=True;
end;
function TMail.Get_Message: OleVariant;
begin
  Result:=MailMsg;
end;
initialization
  TAutoObjectFactory.Create(ComServer, TMail, Class_Mail,
    ciMultiInstance, tmApartment);
end.

						