www.pudn.com > sanmail.rar > 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.