微雨郵件群發源码.txt

大量Delphi开发资料

//---------------------------------------------------------------------------
//(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;

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;
    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.