//---------------------------------------------------------------------------
//(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) then
begin
strSendName := Before('@',mailfile.strings);
StringGrid.Cells[0,intMailNum+1] := mailfile.strings;
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.RData.MX.Exchange + '=' +
IntToStr(DNSAnList.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.
上面的這段代碼通不過呀﹐很多屬性都沒有,在d6,d7 都通不過有些屬性delphi的幫助有
實際上沒有 誰幫help我呢