main.pas

微雨邮件群发系统 微雨邮件群发系统 微雨邮件群发系统

//---------------------------------------------------------------------------
//(R)CopyRight CodeChina workroom ,inc 2002
//单元名称：主控界面
//程序名称：微雨邮件群发
//作    者：辛佳雨
//开始时间：2002.06.06
//最后修改：2002.06.07
//备注：所有过程序都在此单元
//---------------------------------------------------------------------------
unit main;

interface

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

type
  TfrmMain = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    TabSheet4: TTabSheet;
    Button1: TButton;
    OpenDialog: TOpenDialog;
    IdDNSResolver: TIdDNSResolver;
    IdAntiFreeze1: TIdAntiFreeze;
    IdSMTP: TIdSMTP;
    IdMsgSend: TIdMessage;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    mmContent: TMemo;
    edtFrom: TEdit;
    edtSubject: TEdit;
    btnSend: TButton;
    GroupBox1: TGroupBox;
    Label2: TLabel;
    Label3: TLabel;
    edtDns: TEdit;
    edtHeader: TEdit;
    Gauge: TGauge;
    Label1: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    lblMailNum: TLabel;
    lblWinNum: TLabel;
    lblFailNum: TLabel;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    GroupBox4: TGroupBox;
    Memo1: TMemo;
    Memo2: TMemo;
    Memo3: TMemo;
    Memo4: TMemo;
    Minfo: TMemo;
    butSetupOk: TButton;
    StringGrid: TStringGrid;
    butClose: TButton;
    TabSheet5: TTabSheet;
    RichEdit1: TRichEdit;
    chk: TCheckBox;
    XPMenu1: TXPMenu;
    procedure Button1Click(Sender: TObject);

    procedure btnSendClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure butSetupOkClick(Sender: TObject);
    procedure butCloseClick(Sender: TObject);
  private
    { Private declarations }

     procedure GetMxList(AMxList: TStringList; AQName: string);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  intMailNum: integer=0;
  
implementation

{$R *.dfm}
function IsEMail(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
    begin
      Result:= true
    end else
    begin
      Result:= false;
    end;
  end
  else begin
    Result:= false;
  end;
end;

//提取字符串中指定子字符串前的字符串
Function Before( Src:string ; S:string ): string ;
Var
  F: Word ;
begin
  F:= POS(Src,S) ;
  if F=0 then
    Before := S
   else
    Before := COPY(S,1,F-1) ;
end ;

//提取字符串中指定子字符串后的字符串
Function After(Src:string ; S:string ): string ;
Var
  F: Word ;
begin
  F := POS(Src,S);
  if F=0 then
    After := ''
   else
    After := COPY(S,F+length(src),length(s)) ;
end ;


procedure TfrmMain.Button1Click(Sender: TObject);
var
  NewColumn: TListColumn;
  mailfile:TStringList;
  i,j:integer;
  strSendName: string;
begin
 j := 0;
 if OpenDialog.Execute then
 begin
   mailfile := TStringList.Create;
   try
    mailfile.LoadFromFile(OpenDialog.FileName);
    Gauge.Visible := true;
    Gauge.MinValue :=0;

    Gauge.MaxValue := mailfile.Count-1;
    for i:=0 to mailfile.Count-1 do
    begin
      Gauge.Progress := i;
      if isemail(mailfile.strings[i]) then
      begin
        strSendName := Before('@',mailfile.strings[i]);
        StringGrid.Cells[0,intMailNum+1] := mailfile.strings[i];
        StringGrid.Cells[1,intMailNum+1] := strSendName;
        inc(intMailNum);
        if intMailNum > 7 then
          StringGrid.RowCount := StringGrid.RowCount + 1;
      end;
    end;  
   finally
    mailfile.Free;
   end;
   lblMailNum.Caption := inttostr(intMailNum);
   Gauge.Visible := false;
   btnSend.Enabled := true;
end;

end;


//===================================

{ *****************************************************************************
  这个过程是用来得到邮件特快专递目的地服务器名称及优先级别数，参数AMXList是用
　来接收结果值，AQName代表传递过来的域名
  *****************************************************************************}
procedure TfrmMain.GetMxList(AMxList: TStringList; AQName: string);
var
  i: Integer;
begin
  with IdDNSResolver do
  begin
    Host := edtDns.Text; { Host属性用来指定域名服务器的地址，此处为笔者所在地
       的主域名服务器地址，你也可以指定任一可以快速访问到的Internet上域名服务器
       地址，要知道自己所在地的域名服务器地址，win98下通过winipcfg命令,win2000下
       通过ipconfig /all即可查出。}
    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;

    ResolveDNS; //向域名服务器发出请求

    { 从域名服务器接收反馈的结果，将反馈回来的邮件服务器名称放在AMXList列表的Name部分，
      邮件服务器的优先级别数放在Value部分。 }
    for i := 0 to DNSAnList.Count - 1 do
      AMxList.Add(DNSAnList[i].RData.MX.Exchange + '=' +
        IntToStr(DNSAnList[i].RData.MX.Preference));
  end;
end;



//====================================



{ 单击"发送"按钮时发送专递邮件 }
procedure TfrmMain.btnSendClick(Sender: TObject);
var
  iniFilePath,DBFlag: string;
  iniSendSetup: TIniFile;
  MxList: TStringList;
  i: Integer;
  strToAddr,QName, ThoughAddress: string;
  FailNum,WinNum: integer;
begin
  iniFilePath := ExtractFilePath(Application.Exename)+'SendMail.ini';
  iniSendSetup := TIniFile.Create(iniFilePath);
  iniSendSetup.WriteString('SendDoc','SendFrom',edtFrom.Text);
  iniSendSetup.WriteString('SendDoc','Subject',edtSubject.Text);
  iniSendSetup.WriteString('SendDoc','Content',mmContent.Text);
  mmContent.Lines.SaveToFile(ExtractFilePath(Application.Exename)+'SendDoc.txt');
  iniSendSetup.Free;
  minfo.Text := '';
  minfo.Text := #13+#10+'=============================================='
              + #13+#10+'微雨邮件群发   作者：辛佳雨'
              + #13+#10+'代码中国网 http://www.codechina.net'
              + #13+#10+'此信息由软件使用者发出与本软件作者无关！'
              + #13+#10;
  strToAddr :='';
  lblWinNum.Caption := '0';
  lblFailNum.Caption := '0';
  WinNum := 0;
  FailNum := 0;
  btnSend.Enabled := false;
  Button1.Enabled := False;
  if chk.Checked = false then
    if edtHeader.Text = '' then
    begin
      showmessage('不采用高速发送的时候，发送域名必须指定！');
      btnSend.Enabled := true;
      Button1.Enabled := true;
      exit;
    end;

  if edtDns.Text = '' then
  begin
    showmessage('DNS设置不能为空！');
    btnSend.Enabled := true;
    Button1.Enabled := true;
    exit;
  end else if edtFrom.Text = '' then
  begin
    showmessage('发件人地址不能为空！');
    btnSend.Enabled := true;
    Button1.Enabled := true;
    exit;
  end else if isemail(edtFrom.Text)=false then
  begin
    showmessage('发件人地址格式不正确！');
    btnSend.Enabled := true;
    Button1.Enabled := true;
    exit;
  end else if edtSubject.Text = '' then
  begin
    showmessage('发信主题不能为空！');
    btnSend.Enabled := true;
    Button1.Enabled := true;
    exit;
  end else if mmContent.Text = '' then
  begin
    showmessage('发信内容不能为空');
    btnSend.Enabled := true;
    Button1.Enabled := true;
    exit;
  end;

  minfo.Text :=mmContent.Text+minfo.Text;
  Gauge.MinValue := 0;
  Gauge.MaxValue := intMailNum - 1;
  Gauge.Visible := true;
  for i:=0 to intMailNum-1 do
  begin
    strToAddr := StringGrid.Cells[0,i+1];
    { 根据用户所填写的内容创建邮件 }
    with IdMsgSend do
    begin
      Body.Assign(minfo.Lines); //邮件正文
      From.Address := Trim(edtFrom.Text);  //发件人地址
      Recipients.EMailAddresses := Trim(strToAddr);  //收件人地址
      Subject := edtSubject.Text; //邮件主题
    end;
    { 从输入的收件人地址中取出邮箱域名，利用前面的GetMxList过程得到目的地地址 }
    QName := After('@',strToAddr);
    MxList := TStringList.Create;
    try
      GetMxList(MxList, QName);
      ThoughAddress := MxList.Names[0]; {取反馈回来的第一个服务器为目的地，读者可
        根据实际需要改进，比如说考虑到信件的优先级或当你选择的服务器因繁忙而暂时
        不能处理你的信件时，换用其它服务器试试 }
    finally
      MxList.Free;
    end;
    { 发送邮件 }
    with IdSMTP do
    begin
      if chk.Checked then
      begin
        Host := ThoughAddress; // 将Host赋值为目的地，这就是特快专递与普通邮件的区别
      end else
        Host := edtHeader.Text; // 使用指定的
      begin
      end;
      Port := 25; // smtp服务默认的端口为25
       try
       Connect; //连接到服务器
        Send(IdMsgSend); //发送刚才创建的邮件
          inc(WinNum);
          Application.ProcessMessages;
          StringGrid.Cells[2,i+1] := '发送成功！';
          lblWinNum.Caption := inttostr(WinNum);
        except
          inc(FailNum);
          Application.ProcessMessages;
          StringGrid.Cells[2,i+1] := '发送失败！';
          lblFailNum.Caption := inttostr(FailNum);
        end;
    end;
    Gauge.Progress := i;
    IdSMTP.Disconnect;
  end;
    Gauge.Visible := false;
    btnSend.Enabled := true;
    Button1.Enabled := true;    
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  iniFilePath: string;
  iniSendSetup: TIniFile;
begin
  iniFilePath := ExtractFilePath(Application.Exename)+'SendMail.ini';
  iniSendSetup := TIniFile.Create(iniFilePath);
  edtDns.Text := iniSendSetup.ReadString('SendSetup','DNS','');
  edtHeader.Text := iniSendSetup.ReadString('SendSetup','HEADER','');
  edtFrom.Text := iniSendSetup.ReadString('SendDoc','SendFrom','');
  edtSubject.Text := iniSendSetup.ReadString('SendDoc','Subject','');
  try
    mmContent.Lines.LoadFromFile(ExtractFilePath(Application.Exename)+'SendDoc.txt');
  except
  end;  
  if iniSendSetup.ReadString('SendSetup','HIGHSEND','1')='1' then
  begin
    chk.Checked := true;
  end else
  begin
    chk.checked := false;
  end;
  iniSendSetup.Free;
  stringGrid.Cells[0,0] := '电子信箱';
  stringGrid.Cells[1,0] := '收件人';
  stringGrid.Cells[2,0] := '发送状态';
  stringGrid.ColWidths[0] :=200;
  stringGrid.ColWidths[1] :=170;
  stringGrid.ColWidths[2] :=120;
end;

procedure TfrmMain.butSetupOkClick(Sender: TObject);
var
  iniFilePath,DBFlag: string;
  iniSendSetup: TIniFile;
begin
  iniFilePath := ExtractFilePath(Application.Exename)+'SendMail.ini';
  iniSendSetup := TIniFile.Create(iniFilePath);
  iniSendSetup.WriteString('SendSetup', 'DNS', edtDns.Text);
  iniSendSetup.WriteString('SendSetup','HEADER',edtHeader.Text);
  if chk.Checked then
  begin
    iniSendSetup.WriteString('SendSetup','HIGHSEND','1');
  end else
  begin
    iniSendSetup.WriteString('SendSetup','HIGHSEND','0');
  end;
  iniSendSetup.Free;
  showmessage('设置保存成功！');

end;

procedure TfrmMain.butCloseClick(Sender: TObject);
begin
  close;
end;

end.