W
wmyao
Unregistered / Unconfirmed
GUEST, unregistred user!
我动态创建100动态线程,怎么总有1~3个线程没有执行完,我在主程序是这样调用的:
定义:
FMailThreadList: array of TSendMailThread;
//邮件发送线程数组
FMailList : TThreadList ;
//邮件发送线程对象列表
FStopSendMailThread : Boolean ;
FStopSendMail : Boolean ;
FSendMailSucess : Integer ;
//发送邮件成功数
调用:
procedure TfrmSendMsg_Mail.SendMailDone(Sender: TObject);
var
vIndex : Integer ;
vList : TList ;
vData : TSendMailData ;
vMailTo : String ;
begin
vList := FMailList.LockList ;
vIndex := vList.IndexOf( Sender ) ;
vList.Remove( Sender );
FMailList.UnlockList ;
if (SendMailTable.Eof) or FStopSendMailThread or
(SendMailProgressBar.Position >= SendMailTable.RecordCount) then
begin
FStopSendMailThread := True ;
Exit ;
end;
try
SendMailTable.Next ;
vMailTo := SendMailTable.FieldByName('邮件地址').AsString ;
FillSendMailData( vData );
SendMailProgressBar.Position := SendMailProgressBar.Position + 1 ;
SendMailCountLable.Caption := IntToStr(SendMailProgressBar.Position) + '/' + IntToStr(SendMailProgressBar.Max);
vData.ToMail := vMailTo ;
SendMailStatus.Caption := ' 正在发送->' + vData.ToMail ;
FMailThreadList[ vIndex ] := TSendMailThread.Create( vData );
FMailThreadList[ vIndex ].OnTerminate := SendMailDone ;
FMailList.Add( FMailThreadList[ vIndex ] );
except
end;
end;
procedure TfrmSendMsg_Mail.StartSendMailThread;
var
vIndex : Integer ;
vData : TSendMailData ;
vThreadNum : Integer ;
begin
if not FStopSendMailThread then
Exit ;
vThreadNum := 0 ;
bnStartSendMail.Enabled := False ;
bnStopSendMail.Enabled := True ;
FStopSendMailThread := False ;
FStopSendMail := False ;
FSendMailSucess := 0 ;
LockSendMialControl( True );
FSendMailStartTime := Now ;
SendMailTimer.Enabled := True ;
SendMailTimerTimer( nil );
try
if SendMailTable.RecordCount < SendMailThreadNum.IntValue then
vThreadNum := SendMailTable.RecordCount
else
vThreadNum := SendMailThreadNum.IntValue ;
FillSendMailData( vData );
SendMailTable.First ;
SendMailProgressBar.Visible := True ;
SendMailProgressBar.Max := SendMailTable.RecordCount
SendMailProgressBar.Min := 0 ;
SendMailProgressBar.Position := 0 ;
SetLength( FMailThreadList, vThreadNum );
if Assigned( FMailList ) then
FreeAndNil( FMailList ) ;
FMailList := TThreadList.Create ;
for vIndex := 0 to vThreadNum - 1do
begin
if FStopSendMailThread then
Break ;
SendMailProgressBar.Position := SendMailProgressBar.Position + 1 ;
SendMailCountLable.Caption := IntToStr(SendMailProgressBar.Position) + '/' + IntToStr(SendMailProgressBar.Max);
vData.ToMail := SendMailTable.FieldByName('邮件地址').AsString
SendMailStatus.Caption := ' 正在发送->' + vData.ToMail ;
if SendMailSourceList.ItemIndex = 0 then
MarkeSendMailFlag( vData.ToMail );
FMailThreadList[ vIndex ] := TSendMailThread.Create( vData );
FMailThreadList[ vIndex ].OnTerminate := SendMailDone ;
FMailList.Add( FMailThreadList[ vIndex ] );
SendMailTable.Next ;
end;
except
end;
end;
procedure TfrmSendMsg_Mail.SendMailTimerTimer(Sender: TObject);
var
vList : TList ;
begin
if FStopSendMailThread then
begin
try
vList := FMailList.LockList ;
if vList.Count <= 0 then
begin
SendMailStatus.Caption := ' 线程已全部退出' ;
StopSendMailThread ;
end
else
begin
SendMailStatus.Caption := ' 等待' + IntToStr(vList.Count) + '个线程退出' ;
//if vList.Count = 1 then
vList.Remove(vList[0]) ;
end;
FMailList.UnlockList ;
except
StopSendMailThread ;
end;
end;
SendMailTimePanel.Caption := '发送时间:' + ComputerUsedTime(FSendMailStartTime) ;
end;
procedure TfrmSendMsg_Mail.StopSendMailThread;
var
vTmp : String ;
vTotal : Integer ;
begin
bnStartSendMail.Enabled := True ;
bnStopSendMail.Enabled := False ;
SendMailProgressBar.Visible := False ;
FStopSendMail := True ;
LockSendMialControl ;
SendMailTimer.Enabled := False ;
if EMailTable.Active then
EMailTable.Refresh ;
vTotal := SendMailProgressBar.Position ;
vTmp := ' 成功:' + IntToStr( FSendMailSucess ) + '封,占:' +
IntToStr(Round((FSendMailSucess / vTotal)*100)) + '%;失败:' +
IntToStr( vTotal - FSendMailSucess ) + '封,占:' +
IntToStr(Round(((vTotal-FSendMailSucess)/vTotal)*100)) +'%';
SendMailStatus.Caption := vTmp ;
end;
//线程定义
TSendMailThread = class( TThread )
public
constructor Create( vData : TSendMailData );
destructor Destroy;
override;
private
{ Private declarations }
FSmtp : TIdSMTP ;
FSmtpMessage : TIdMessage ;
FDnsHost : String ;
FToMail : String ;
procedure AddLog( vLog : String );
procedure SendMail ;
function SendToMail( vMailServer : String ) : Boolean ;
protected
procedure Execute;
override;
end;
function GetEmailServers( vDNSHost,vHostName : String;
var vMailServerList : String ) : Boolean ;
//根据域名取邮箱服务器地址
function PadZero(s: String): String;
begin
if length(s) < 2 then
s := '0' + s;
Result := s;
end;
var
i,x : integer;
LDomainPart : String;
LMXRecord : TMXRecord;
vList : TStringList ;
vDNS : TIdDNSResolver ;
begin
vList := TStringList.Create ;
vDNS := TIdDNSResolver.Create( nil );
with vDNSdo
begin
QueryResult.Clear;
QueryRecords := [qtMX];
Port := 53 ;
Host := vDNSHost ;
ReceiveTimeout := 5000;
if Pos( '@', vHostName ) > 0 then
LDomainPart := Copy(vHostName,pos('@',vHostName)+1,Length(vHostName))
else
LDomainPart := vHostName ;
try
Resolve(LDomainPart);
if QueryResult.Count > 0 then
begin
for i := 0 to QueryResult.Count - 1do
begin
LMXRecord := TMXRecord(QueryResult.Items);
vList.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
end;
vList.Sorted := False;
for i := 0 to vList.count - 1do
begin
x := pos('=',vList.Strings);
if x > 0 then
vList.Strings := Copy(vList.Strings,x+1,length(vList.Strings));
end;
vList.Sorted := True;
vList.Duplicates := dupIgnore;
Result := True;
end
else
begin
Result := False;
end;
except
Result := False;
end;
end;
if Result and (vList.Count > 0) then
begin
vList.Delimiter := ';';
vMailServerList := vList.DelimitedText ;
end
else
Result := False ;
FreeAndNil( vDNS );
FreeAndNil( vList );
end;
constructor TSendMailThread.Create(vData : TSendMailData);
begin
inherited Create( False );
FSmtp := TIdSMTP.Create(nil) ;
FSmtpMessage := TIdMessage.Create(FSmtp) ;
FSmtpMessage.From.Text := vData.SenderMail ;
FSmtpMessage.From.Name := vData.SenderName ;
FSmtpMessage.Subject := vData.SendSubject ;
FSmtpMessage.Sender.Text := vData.SenderMail ;
//FSmtpMessage.ReceiptRecipient.Text := vData.ToMail ;
FSmtpMessage.Recipients.EMailAddresses := vData.ToMail ;
FSmtpMessage.Body.Text := vData.SendBody ;
FSmtpMessage.CharSet := 'US-ASCII';
FSmtpMessage.ContentTransferEncoding := 'quoted-printable';
FSmtpMessage.ContentType := vData.SendMailType ;
FSmtpMessage.Priority := vData.SendMailLevel ;
FDnsHost := vData.DnsServer ;
FToMail := vData.ToMail ;
Priority := tpIdle ;
FreeOnTerminate := True;
end;
destructor TSendMailThread.Destroy;
begin
if Assigned( FSmtpMessage ) then
FreeAndNil( FSmtpMessage );
if Assigned( FSmtp ) then
FreeAndNil( FSmtp );
inherited Destroy;
end;
procedure TSendMailThread.AddLog(vLog: String);
begin
if Assigned( frmSendMsg_Mail ) then
begin
if frmSendMsg_Mail.SendMailLogList.Items.Count > 1000 then
frmSendMsg_Mail.SendMailLogList.Items.Clear ;
frmSendMsg_Mail.SendMailLogList.ItemIndex := frmSendMsg_Mail.SendMailLogList.Items.Add( vLog ) ;
end;
end;
procedure TSendMailThread.Execute;
begin
FreeOnTerminate := True;
try
if not Terminated then
begin
Sleep( 1000 );
SendMail;
end
else
Exit ;
except
end;
end;
procedure TSendMailThread.SendMail ;
var
vServerList : String ;
vList : TStrings ;
vIndex : Integer ;
vRet : Boolean ;
begin
if Terminated then
Exit ;
vRet := False ;
vList := TStringList.Create ;
vList.Delimiter := ';';
if GetEmailServers( FDnsHost, FToMail, vServerList ) then
begin
vList.DelimitedText := vServerList ;
for vIndex := 0 to vList.Count - 1do
begin
if Terminated then
Break ;
if SendToMail( vList.Strings[ vIndex ] ) then
begin
vRet := True ;
Break ;
end;
end;
end;
if vRet then
begin
AddLog( FToMail + '->成功' ) ;
Inc( frmSendMsg_Mail.FSendMailSucess ) ;
end
else
AddLog( FToMail + '->失败' );
FreeAndNil( vList );
end;
function TSendMailThread.SendToMail(vMailServer: String): Boolean;
begin
Result := False ;
if Terminated then
Exit ;
with FSmtpdo
begin
Port := 25 ;
try
Host := vMailServer ;
Connect(10000);
Send(FSmtpMessage);
Disconnect ;
Result := True ;
except
if connected then
try disconnect;
except end;
Result := False ;
end;
end;
end;
定义:
FMailThreadList: array of TSendMailThread;
//邮件发送线程数组
FMailList : TThreadList ;
//邮件发送线程对象列表
FStopSendMailThread : Boolean ;
FStopSendMail : Boolean ;
FSendMailSucess : Integer ;
//发送邮件成功数
调用:
procedure TfrmSendMsg_Mail.SendMailDone(Sender: TObject);
var
vIndex : Integer ;
vList : TList ;
vData : TSendMailData ;
vMailTo : String ;
begin
vList := FMailList.LockList ;
vIndex := vList.IndexOf( Sender ) ;
vList.Remove( Sender );
FMailList.UnlockList ;
if (SendMailTable.Eof) or FStopSendMailThread or
(SendMailProgressBar.Position >= SendMailTable.RecordCount) then
begin
FStopSendMailThread := True ;
Exit ;
end;
try
SendMailTable.Next ;
vMailTo := SendMailTable.FieldByName('邮件地址').AsString ;
FillSendMailData( vData );
SendMailProgressBar.Position := SendMailProgressBar.Position + 1 ;
SendMailCountLable.Caption := IntToStr(SendMailProgressBar.Position) + '/' + IntToStr(SendMailProgressBar.Max);
vData.ToMail := vMailTo ;
SendMailStatus.Caption := ' 正在发送->' + vData.ToMail ;
FMailThreadList[ vIndex ] := TSendMailThread.Create( vData );
FMailThreadList[ vIndex ].OnTerminate := SendMailDone ;
FMailList.Add( FMailThreadList[ vIndex ] );
except
end;
end;
procedure TfrmSendMsg_Mail.StartSendMailThread;
var
vIndex : Integer ;
vData : TSendMailData ;
vThreadNum : Integer ;
begin
if not FStopSendMailThread then
Exit ;
vThreadNum := 0 ;
bnStartSendMail.Enabled := False ;
bnStopSendMail.Enabled := True ;
FStopSendMailThread := False ;
FStopSendMail := False ;
FSendMailSucess := 0 ;
LockSendMialControl( True );
FSendMailStartTime := Now ;
SendMailTimer.Enabled := True ;
SendMailTimerTimer( nil );
try
if SendMailTable.RecordCount < SendMailThreadNum.IntValue then
vThreadNum := SendMailTable.RecordCount
else
vThreadNum := SendMailThreadNum.IntValue ;
FillSendMailData( vData );
SendMailTable.First ;
SendMailProgressBar.Visible := True ;
SendMailProgressBar.Max := SendMailTable.RecordCount
SendMailProgressBar.Min := 0 ;
SendMailProgressBar.Position := 0 ;
SetLength( FMailThreadList, vThreadNum );
if Assigned( FMailList ) then
FreeAndNil( FMailList ) ;
FMailList := TThreadList.Create ;
for vIndex := 0 to vThreadNum - 1do
begin
if FStopSendMailThread then
Break ;
SendMailProgressBar.Position := SendMailProgressBar.Position + 1 ;
SendMailCountLable.Caption := IntToStr(SendMailProgressBar.Position) + '/' + IntToStr(SendMailProgressBar.Max);
vData.ToMail := SendMailTable.FieldByName('邮件地址').AsString
SendMailStatus.Caption := ' 正在发送->' + vData.ToMail ;
if SendMailSourceList.ItemIndex = 0 then
MarkeSendMailFlag( vData.ToMail );
FMailThreadList[ vIndex ] := TSendMailThread.Create( vData );
FMailThreadList[ vIndex ].OnTerminate := SendMailDone ;
FMailList.Add( FMailThreadList[ vIndex ] );
SendMailTable.Next ;
end;
except
end;
end;
procedure TfrmSendMsg_Mail.SendMailTimerTimer(Sender: TObject);
var
vList : TList ;
begin
if FStopSendMailThread then
begin
try
vList := FMailList.LockList ;
if vList.Count <= 0 then
begin
SendMailStatus.Caption := ' 线程已全部退出' ;
StopSendMailThread ;
end
else
begin
SendMailStatus.Caption := ' 等待' + IntToStr(vList.Count) + '个线程退出' ;
//if vList.Count = 1 then
vList.Remove(vList[0]) ;
end;
FMailList.UnlockList ;
except
StopSendMailThread ;
end;
end;
SendMailTimePanel.Caption := '发送时间:' + ComputerUsedTime(FSendMailStartTime) ;
end;
procedure TfrmSendMsg_Mail.StopSendMailThread;
var
vTmp : String ;
vTotal : Integer ;
begin
bnStartSendMail.Enabled := True ;
bnStopSendMail.Enabled := False ;
SendMailProgressBar.Visible := False ;
FStopSendMail := True ;
LockSendMialControl ;
SendMailTimer.Enabled := False ;
if EMailTable.Active then
EMailTable.Refresh ;
vTotal := SendMailProgressBar.Position ;
vTmp := ' 成功:' + IntToStr( FSendMailSucess ) + '封,占:' +
IntToStr(Round((FSendMailSucess / vTotal)*100)) + '%;失败:' +
IntToStr( vTotal - FSendMailSucess ) + '封,占:' +
IntToStr(Round(((vTotal-FSendMailSucess)/vTotal)*100)) +'%';
SendMailStatus.Caption := vTmp ;
end;
//线程定义
TSendMailThread = class( TThread )
public
constructor Create( vData : TSendMailData );
destructor Destroy;
override;
private
{ Private declarations }
FSmtp : TIdSMTP ;
FSmtpMessage : TIdMessage ;
FDnsHost : String ;
FToMail : String ;
procedure AddLog( vLog : String );
procedure SendMail ;
function SendToMail( vMailServer : String ) : Boolean ;
protected
procedure Execute;
override;
end;
function GetEmailServers( vDNSHost,vHostName : String;
var vMailServerList : String ) : Boolean ;
//根据域名取邮箱服务器地址
function PadZero(s: String): String;
begin
if length(s) < 2 then
s := '0' + s;
Result := s;
end;
var
i,x : integer;
LDomainPart : String;
LMXRecord : TMXRecord;
vList : TStringList ;
vDNS : TIdDNSResolver ;
begin
vList := TStringList.Create ;
vDNS := TIdDNSResolver.Create( nil );
with vDNSdo
begin
QueryResult.Clear;
QueryRecords := [qtMX];
Port := 53 ;
Host := vDNSHost ;
ReceiveTimeout := 5000;
if Pos( '@', vHostName ) > 0 then
LDomainPart := Copy(vHostName,pos('@',vHostName)+1,Length(vHostName))
else
LDomainPart := vHostName ;
try
Resolve(LDomainPart);
if QueryResult.Count > 0 then
begin
for i := 0 to QueryResult.Count - 1do
begin
LMXRecord := TMXRecord(QueryResult.Items);
vList.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
end;
vList.Sorted := False;
for i := 0 to vList.count - 1do
begin
x := pos('=',vList.Strings);
if x > 0 then
vList.Strings := Copy(vList.Strings,x+1,length(vList.Strings));
end;
vList.Sorted := True;
vList.Duplicates := dupIgnore;
Result := True;
end
else
begin
Result := False;
end;
except
Result := False;
end;
end;
if Result and (vList.Count > 0) then
begin
vList.Delimiter := ';';
vMailServerList := vList.DelimitedText ;
end
else
Result := False ;
FreeAndNil( vDNS );
FreeAndNil( vList );
end;
constructor TSendMailThread.Create(vData : TSendMailData);
begin
inherited Create( False );
FSmtp := TIdSMTP.Create(nil) ;
FSmtpMessage := TIdMessage.Create(FSmtp) ;
FSmtpMessage.From.Text := vData.SenderMail ;
FSmtpMessage.From.Name := vData.SenderName ;
FSmtpMessage.Subject := vData.SendSubject ;
FSmtpMessage.Sender.Text := vData.SenderMail ;
//FSmtpMessage.ReceiptRecipient.Text := vData.ToMail ;
FSmtpMessage.Recipients.EMailAddresses := vData.ToMail ;
FSmtpMessage.Body.Text := vData.SendBody ;
FSmtpMessage.CharSet := 'US-ASCII';
FSmtpMessage.ContentTransferEncoding := 'quoted-printable';
FSmtpMessage.ContentType := vData.SendMailType ;
FSmtpMessage.Priority := vData.SendMailLevel ;
FDnsHost := vData.DnsServer ;
FToMail := vData.ToMail ;
Priority := tpIdle ;
FreeOnTerminate := True;
end;
destructor TSendMailThread.Destroy;
begin
if Assigned( FSmtpMessage ) then
FreeAndNil( FSmtpMessage );
if Assigned( FSmtp ) then
FreeAndNil( FSmtp );
inherited Destroy;
end;
procedure TSendMailThread.AddLog(vLog: String);
begin
if Assigned( frmSendMsg_Mail ) then
begin
if frmSendMsg_Mail.SendMailLogList.Items.Count > 1000 then
frmSendMsg_Mail.SendMailLogList.Items.Clear ;
frmSendMsg_Mail.SendMailLogList.ItemIndex := frmSendMsg_Mail.SendMailLogList.Items.Add( vLog ) ;
end;
end;
procedure TSendMailThread.Execute;
begin
FreeOnTerminate := True;
try
if not Terminated then
begin
Sleep( 1000 );
SendMail;
end
else
Exit ;
except
end;
end;
procedure TSendMailThread.SendMail ;
var
vServerList : String ;
vList : TStrings ;
vIndex : Integer ;
vRet : Boolean ;
begin
if Terminated then
Exit ;
vRet := False ;
vList := TStringList.Create ;
vList.Delimiter := ';';
if GetEmailServers( FDnsHost, FToMail, vServerList ) then
begin
vList.DelimitedText := vServerList ;
for vIndex := 0 to vList.Count - 1do
begin
if Terminated then
Break ;
if SendToMail( vList.Strings[ vIndex ] ) then
begin
vRet := True ;
Break ;
end;
end;
end;
if vRet then
begin
AddLog( FToMail + '->成功' ) ;
Inc( frmSendMsg_Mail.FSendMailSucess ) ;
end
else
AddLog( FToMail + '->失败' );
FreeAndNil( vList );
end;
function TSendMailThread.SendToMail(vMailServer: String): Boolean;
begin
Result := False ;
if Terminated then
Exit ;
with FSmtpdo
begin
Port := 25 ;
try
Host := vMailServer ;
Connect(10000);
Send(FSmtpMessage);
Disconnect ;
Result := True ;
except
if connected then
try disconnect;
except end;
Result := False ;
end;
end;
end;