main.pas

邮件群发源码

begin
  for I := 0 to ListView1.Items.Count - 1 do
  begin
    ListView1.Items[I].Checked := False;
  end;
end;

procedure TfrmMain.RzToolButton8Click(Sender: TObject);
var
  I: integer;
begin
  for I := 0 to ListView1.Items.Count - 1 do
  begin
    ListView1.Items[I].Checked := not ListView1.Items[I].Checked;
  end;
end;

procedure TfrmMain.RzToolButton9Click(Sender: TObject);
begin
  frmImportFromDB.Show;
end;

procedure TfrmMain.SendEmail1;
  function GetMailQty: integer;
  var
    I, J: integer;
  begin
    J := 0;
    for I := 0  to ListView1.Items.Count - 1 do
    begin
      ListView1.Items[I].Selected := False;
      if ListView1.Items[I].Checked = True then
      begin
        ListView1.Items[I].ImageIndex := 0;
        J := J + 1;
      end;
    end;
    Result := J;
  end;
var
  total, I, J: integer;
  AnItem: TListItem;
  MailAddr, X1: string;
begin
  X1 := '"'+Edit5.Text+'" ' + '<' + RzEdit8.Text + '>';
  total := GetMailQty;
  J := 0;
  if total > 0 then
  begin
    if Application.MessageBox('是否现在发送邮件?', '确认', MB_YESNO+MB_ICONQUESTION+MB_DEFBUTTON2)=idyes then
    begin
      iCount := 0;
     TimerSend.Enabled := True;
      ListView1.MultiSelect := False;
      ProgressBar1.Position := 0;
      ProgressBar1.Max := total;
      SuccessList.Lines.Clear;
      FailList.Lines.Clear;
      if (RzcheckBox1.Checked = True) and (Length(RzEdit8.Text) > 0) then
       begin
         MailMessage.ExtraHeaders.Clear;
         MailMessage.ExtraHeaders.Add('Disposition-Notification-To: ' + X1);
       end;
      for I := 0 to ListView1.Items.Count - 1 do
      begin
        AnItem := ListView1.Items[I];
        if AnItem.Checked = True then
        begin
          try
            J := J + 1;
            MailAddr := AnItem.SubItems[0];
            AnItem.ImageIndex := 3;
            AnItem.Selected := True;
            AnItem.MakeVisible(True);
            //
            Label15.Caption := Format('正在发送邮件:' + MailAddr + ', [%d / %d 封]', [J, Total]);
            ProgressBar1.Position := ProgressBar1.Position + 1;
            Application.ProcessMessages;
            Mail.Disconnect;
            Mail.Host := Edit1.Text;
            Mail.Username := Edit2.Text;
            Mail.Password := Edit3.Text;
            Mail.AuthenticationType := atLogin;
            Mail.Connect;
            MailMessage.From.Name := Edit5.Text;
            if Length(Edit2.Text) > 0 then
            MailMessage.From.Address := Edit4.Text;
            MailMessage.ContentType := RzEdit7.Text;
            MailMessage.CharSet := RzEdit9.Text;
            MailMessage.ReplyTo.Clear;

            MailMessage.Subject := RzEdit6.Text;
            MailMessage.Body.SetText(Pchar(TrimMessage(RzMemo2.Lines.GetText, '<%mail%>', MailAddr)));
            MailMessage.Recipients.EMailAddresses := MailAddr;
            Mail.Send(MailMessage);
            SuccessList.Lines.Add(AnItem.Caption + '<|>' + MailAddr);
            AnItem.ImageIndex := 1;
          except
            on E: Exception do
            begin
              AnItem.ImageIndex := 2;
              AnItem.Selected := True;
              FailList.Lines.Add(AnItem.Caption + '<|>' + MailAddr);
            end;
          end;
        end;
      end;
      progressbar1.Position := 0;
      Label18.Caption := '剩余时间：00:00:00';
      TimerSend.Enabled := False;
      Label15.Caption := '邮件发送完毕！';
      ListView1.MultiSelect := True;
    end;
  end
  else
  MessageDlg('未指定收件人!', mtInformation, [MBOK], 0);
end;

procedure TfrmMain.RzToolButton10Click(Sender: TObject);
begin
  SendEmail1;
end;

function TfrmMain.TrimMessage(AMessage, AIdent, AEmail: string): string;
var
  I: integer;
  S1, S2: string;
  S: string;
begin
  AIdent := '<%mail%>';
  S := AMessage;
  while AnsiPos(AIdent, S) > 0 do
  begin
    I := AnsiPos(AIdent, S);
    if I > 0 then
    begin
      S1 := Copy(S, 1, I - 1);
      S2 := Copy(S, I + 8, Length(S));
      S := S1 + AEmail + S2;
    end
    else
    begin
      S := AMessage;
    end;
  end;
  Result := S;
end;
procedure TfrmMain.SendEmail2;
  function GetMailQty: integer;
  var
    I, J: integer;
  begin
    J := 0;
    for I := 0  to ListView1.Items.Count - 1 do
    begin
      ListView1.Items[I].Selected := False;
      if ListView1.Items[I].Checked = True then
      begin
        ListView1.Items[I].ImageIndex := 0;
        J := J + 1;
        //ListView1.Items[I].SubItems[1] := '';
      end;
    end;
    Result := J;
  end;
var
  total, I: integer;
  AnItem: TListItem;
  MailAddr, X1: string;
  AD: TIdEMailAddressItem;
begin
  Label15.Caption := '';
  X1 := '"'+Edit5.Text+'" ' + '<' + RzEdit8.Text + '>';
  total := GetMailQty;
  if total > 0 then
  begin
    if Application.MessageBox('是否现在发送邮件?', '确认', MB_YESNO+MB_ICONQUESTION+MB_DEFBUTTON2)=idyes then
    begin
      ProgressBar1.Position := 0;
      ProgressBar1.Max := total;
      SuccessList.Lines.Clear;
      FailList.Lines.Clear;
      //Memo2.Lines.Add('******SENT LIST ********');
      if (RzcheckBox1.Checked = True) and (Length(RzEdit8.Text) > 0) then
       begin
         MailMessage.ExtraHeaders.Clear;
         MailMessage.ExtraHeaders.Add('Disposition-Notification-To: ' + X1);
       end;
       MailMessage.Recipients.Clear;
       for I := 0 to ListView1.Items.Count - 1 do
       begin
         AnItem := ListView1.Items[I];
         if AnItem.Checked then
         begin
           AD := MailMessage.Recipients.Add;
           AD.Name := AnItem.Caption;
           AD.Address := AnItem.SubItems[0];
         end;
       end;
       //发送邮件;
       Mail.Disconnect;
       Mail.Host := Edit1.Text;
       Mail.Username := Edit2.Text;
       Mail.Password := Edit3.Text;
       Mail.AuthenticationType := atLogin;
       Mail.Connect;
       //MailMessage.Clear;
       MailMessage.From.Name := Edit5.Text;
       if Length(Edit2.Text) > 0 then
       MailMessage.From.Address := Edit4.Text;
       MailMessage.ContentType := RzEdit7.Text;
       MailMessage.CharSet := RzEdit9.Text;
       MailMessage.ReplyTo.Clear;

       MailMessage.Subject := RzEdit6.Text;
       MailMessage.Body.SetText(Pchar(TrimMessage(RzMemo2.Lines.GetText, '<%mail%>', MailAddr)));
       Mail.Send(MailMessage);
      
      progressbar1.Position := 0;
      Label15.Caption := '邮件发送完毕！';
    end;
  end
  else
  MessageDlg('no recipients specified!', mtInformation, [MBOK], 0);
end;

procedure TfrmMain.RzToolButton11Click(Sender: TObject);
begin
  Self.SendEmail2;
end;

procedure TfrmMain.SetAddrQty;
begin
  Label16.Caption := '地址总数：' + IntToStr(ListView1.Items.Count);
end;

procedure TfrmMain.RzBitBtn5Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    SuccessList.Lines.SaveToFile(SaveDialog1.FileName);
end;

procedure TfrmMain.RzBitBtn6Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    FailList.Lines.SaveToFile(SaveDialog1.FileName);
end;

procedure TfrmMain.FillAddrList(AMemo: TRzMemo);
var
  I, J: integer;
  AnItem: TListItem;
begin
  if Application.MessageBox('此操作将清除当前发送列表的所有地址！是否继续？',
    '确认', MB_YESNO + MB_ICONQUESTION) = IDYES then
    begin
      ListView1.Items.Clear;
      for I := 0 to AMemo.Lines.Count - 1 do
      begin
        if AnsiPos('<|>', AMemo.Lines[I]) > 0 then
         begin
           J := AnsiPos('<|>', AMemo.Lines[I]);
           AnItem := ListView1.Items.Add;
           AnItem.Caption := Copy(AMemo.Lines[I], 1, J - 1);
           AnItem.SubItems.Add(Copy(AMemo.Lines[I], J + 3, Length(AMemo.Lines[I])));
         end;
      end;
    end;
end;

procedure TfrmMain.RzBitBtn7Click(Sender: TObject);
begin
  FillAddrList(SuccessList);
end;

procedure TfrmMain.RzBitBtn8Click(Sender: TObject);
begin
  FillAddrList(FailList);
end;

procedure TfrmMain.RzBitBtn9Click(Sender: TObject);
begin
  if Application.MessageBox('确实要清除！',
    '确认', MB_YESNO + MB_ICONQUESTION) = IDYES then
      SuccessList.Lines.Clear;
end;

procedure TfrmMain.RzBitBtn10Click(Sender: TObject);
begin
  if Application.MessageBox('确实要清除！',
    '确认', MB_YESNO + MB_ICONQUESTION) = IDYES then
      FailList.Lines.Clear;
end;

function TfrmMain.DigitalToTime(I: integer): string;
  function FrmStr(S: string): string;
  begin
    Result := S;
    if Length(Result) = 1 then Result := '0' + Result;
  end;
var
  A, B, C: integer;
  H, M, S: string;
begin
  A := I div 3600;
  B := (I - A * 3600) div 60;
  C := I - (A * 3600 + B * 60);
  H := IntToStr(A);
  M := IntToStr(B);
  S := IntToStr(C);
  Result := FrmStr(H) + ':' + FrmStr(M) + ':' + FrmStr(S);
end;

procedure TfrmMain.TimerSendTimer(Sender: TObject);
var
  TimeLeft: integer;
begin
  Inc(iCount);
  if ProgressBar1.Max > 0 then
  begin
    TimeLeft := ProgressBar1.Max - iCount;
    Label17.Caption := '已用时间：' + DigitalToTime(iCount);
    Label18.Caption := '剩余时间：' + DigitalToTime(TimeLeft);
    Application.ProcessMessages;
  end;
end;

end.