unit1.pas

delphi开发的直接收发邮件的软件的源码

unit Unit1;
{
采用idsmtp来做邮件特快专递的一个例子代码。
部分代码引用了网上公开的一个例子程序。
我对原例子的dns部分做了改进，现在是直接获得您当前正在使用的dns地址，无须用户手工输入。

chengrong fu 2006-8-2
有任何意见和建议可以给我来信：[e-mail]
}
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent,
  IdUDPBase, IdUDPClient, IdDNSResolver, StdCtrls, Grids, ValEdit, ExtCtrls,
  IdMessage, IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP,
  ComCtrls,GetDnsList;

type
  TForm1 = class(TForm)
    IdDNSResolver: TIdDNSResolver;
    btnSend: TButton;
    IdSMTP: TIdSMTP;
    IdMsgSend: TIdMessage;
    mmContent: TMemo;
    Label1: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    edtFrom: TEdit;
    Label6: TLabel;
    edtSubject: TEdit;
    Label2: TLabel;
    ProgressBar1: TProgressBar;
    Edit1: TEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure btnSendClick(Sender: TObject);
    procedure IdSMTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure IdSMTPWork(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure IdSMTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
  private
    { Private declarations }
    Jit_file_size: integer;
    jit_st1: Tstringlist;
    function GetMxList(jit_dnshost,AQName: string): string;
    function jit_send(dns,jit_to: string): boolean;
    function Jit_dns(s: string): string;
    function send1: boolean;
    function send2: boolean;
    function send3: boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function FileLength(Filename:string):integer;
var
  fp:file of byte;
begin
  AssignFile(fp,Filename);
  Reset(fp);
  Result := FileSize(fp);
  CloseFile(fp);
end;
function IsEMail(const EMail: String): Boolean;

var

s: String;

ETpos: Integer;

begin

ETpos:= pos('@',
EMail);

if ETpos > 1 then

begin

s:= copy(EMail,

ETpos+1,

Length(EMail));

if (pos('.',

s) > 1) and (pos('.',

s) < length(s)) then

Result:= true else Result:= false;

end

else

Result:= false;

end;

{ TForm1 }

{ *****************************************************************************
  这个过程是用来得到邮件特快专递目的地服务器名称及优先级别数，参数AMXList是用
　来接收结果值，AQName代表传递过来的域名
  *****************************************************************************}
function TForm1.GetMxList(jit_dnshost,AQName: string): string;
begin
result:= '';
  with IdDNSResolver do
  begin
    Host := jit_dnshost; 
    ReceiveTimeout := 10000;   // 在指定的时间内得不到域名服务器的反馈，则视为失败。
    ClearVars;    // 清除前一次查询所反馈回来的资源记录

    { 构建此次查询的头部结构 }
    with DNSHeader do
    begin
      Qr := False; // False 代表查询
      Opcode := 0; // 0代表标准域名查询
      RD := True; //域名服务器可以进行递归查询
      QDCount := 1; //查询的数量
    end;

    { 构建要查询的问题 }
    DNSQDList.Clear;
    with DNSQDList.Add do
    begin
      QName := AQName; //要查询的域名
      QType := cMX; //QTYPE指定要查询的资源记录的种类，值为cMX代表邮件交换记录
      QClass := cIN;
    end;
   try
    ResolveDNS; //向域名服务器发出请求
    result:= DNSAnList[0].RData.MX.Exchange;
    finally

   end;



    { 从域名服务器接收反馈的结果，将反馈回来的邮件服务器名称放在AMXList列表的Name部分，
      邮件服务器的优先级别数放在Value部分。 }

  end;
end;

{ 单击"发送"按钮时发送专递邮件 }
procedure TForm1.btnSendClick(Sender: TObject);
begin
  { 根据用户所填写的内容创建邮件 }

  if edtSubject.Text= '' then
   begin
    messagebox(handle,'请输入留言的标题。','标题', mb_ok or MB_ICONWARNING);
    exit;
   end;
  if edtFrom.Text= '' then
   begin
    messagebox(handle,'请输入您的电子邮件地址。','邮件', mb_ok or MB_ICONWARNING);
    exit;
   end;
  if not IsEMail(edtFrom.Text) then
   begin
    messagebox(handle,'请输入有效的电子邮件地址。','邮件', mb_ok or MB_ICONWARNING);
    exit;
   end;

  if mmContent.Text= '' then
   begin
    messagebox(handle,'请输入您反馈信息的详细描述。','描述', mb_ok or MB_ICONWARNING);
    exit;
   end;
btnSend.Enabled:= false;
screen.Cursor:= crhourglass;

  { 从输入的收件人地址中取出邮箱域名，利用前面的GetMxList过程得到目的地地址 }
  label2.Caption:= '开始解析服务器地址';
  application.ProcessMessages;





   if not send1 then
    if not send2 then
      if not send3 then
       begin
         messagebox(handle,'很抱歉，问题反馈失败，或者您可以直接发email到 [e-mail]','失败',mb_ok or MB_ICONERROR); //发送完毕后提示
         label2.Caption:= '问题反馈失败。';
         btnSend.Enabled:= true;
        screen.Cursor:= crdefault;
        exit;
       end;

 form1.Close;
  { 发送邮件 }

end;

procedure TForm1.IdSMTPWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
 if AWorkCountMax= 0 then
   ProgressBar1.Max:= round((Jit_file_size + length(mmContent.Text)) * 1.5)
 else
 ProgressBar1.Max:=AWorkCountMax;

  ProgressBar1.Position:=0;
end;

procedure TForm1.IdSMTPWork(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
 ProgressBar1.Position:=AWorkCount;
 application.ProcessMessages;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 if opendialog1.Execute then
  begin
   edit1.Text:= opendialog1.FileName;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 jit_st1:= Tstringlist.Create;
  jit_st1.LoadFromFile(ExtractFilePath(application.ExeName)+ 'mailset.txt');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 jit_st1.Free;
end;

function TForm1.jit_send(dns, jit_to: string): boolean;
begin
result:= false;
 with IdMsgSend do
  begin
    Body.Assign(mmContent.Lines); //邮件正文
    From.Address := Trim(edtFrom.Text);  //发件人地址
    Recipients.EMailAddresses := Trim(jit_to);  //收件人地址
    Subject := edtSubject.Text; //邮件主题
  end;
  if edit1.Text<> '' then
   begin
    if FileExists(trim(edit1.Text)) then
     begin
      IdMsgSend.MessageParts.Clear;
      TIdAttachment.Create(IdMsgSend.MessageParts,trim(edit1.Text));
      Jit_file_size:= FileLength(edit1.Text);
     end;
   end;

   label2.Caption:= '开始连接服务器';
   application.ProcessMessages;
  with IdSMTP do
  begin
    Host := dns; // 将Host赋值为目的地，这就是特快专递与普通邮件的区别
    Port := 25; // smtp服务默认的端口为25
    Connect; //连接到服务器
     label2.Caption:= '连接服务器成功，开始发送信息';
     application.ProcessMessages;
    try
       Send(IdMsgSend); //发送刚才创建的邮件
       label2.Caption:= '发送完成';
       application.ProcessMessages;
      messagebox(handle,'您反馈的问题已经发出，感谢您的意见和建议。','感谢',mb_ok or MB_ICONINFORMATION); //发送完毕后提示
       result:= true;
    finally
      btnSend.Enabled:= true;
      screen.Cursor:= crdefault;
      Disconnect; //断开服务器连接
    end;
  end;

end;

function TForm1.Jit_dns(s: string): string;
var QName,d2: string;
begin
d2:= '';
 QName := TrimRight(copy(s, Pos('@', s) + 1, Length(s)));
  d2:= GetDnsIp;
    if d2= '' then
     begin
            result:= GetMxList(jit_st1.Values['DNS1'], QName);
               if result= '' then
               result:= GetMxList(jit_st1.Values['DNS2'], QName);
               if result= '' then
              result:= GetMxList(jit_st1.Values['DNS3'], QName);
     end else begin
               result:= GetMxList(d2, QName);
               if result= '' then
               result:= GetMxList(jit_st1.Values['DNS1'], QName);
               if result= '' then
              result:= GetMxList(jit_st1.Values['DNS2'], QName);
              end;


end;

function TForm1.send1: boolean;
var ss: string;
begin
result:= false;
 ss:= Jit_dns(jit_st1.Values['mail1']);
 if ss<> '' then
  begin
   if jit_send(ss,jit_st1.Values['mail1']) then
    result:= true;
  end;
end;

function TForm1.send2: boolean;
var ss: string;
begin
result:= false;
 ss:= Jit_dns(jit_st1.Values['mail2']);
 if ss<> '' then
  begin
   if jit_send(ss,jit_st1.Values['mail2']) then
    result:= true;
  end;

end;

function TForm1.send3: boolean;
var ss: string;
begin
result:= false;
 ss:= Jit_dns(jit_st1.Values['mail3']);
 if ss<> '' then
  begin
   if jit_send(ss,jit_st1.Values['mail3']) then
    result:= true;
  end;

end;

procedure TForm1.IdSMTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  ProgressBar1.Position:=ProgressBar1.Max;
end;

end.