Marco Cantù 1998, Mastering Delphi 4

Project: SENDLIST.DPR


Project Structure


SENDLIST.DPR

program SendList;

uses
  Forms,
  SendForm in 'SendForm.pas' {MainForm};

{$R *.RES}

begin
  Application.Title := 'SimpleMail';
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.

SENDFORM.PAS

unit SendForm;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
  StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls,
  Psock, NMsmtp;

type
  TMainForm = class(TForm)
    Panel2: TPanel;
    reMessageText: TRichEdit;
    Panel1: TPanel;
    Label1: TLabel;
    eName: TEdit;
    Splitter1: TSplitter;
    ListLog: TListBox;
    Label2: TLabel;
    eSubject: TEdit;
    Label3: TLabel;
    BbtnAddToList: TButton;
    ListAddr: TListBox;
    BtnRemove: TButton;
    BtnFind: TButton;
    Mail: TNMSMTP;
    Label5: TLabel;
    eFrom: TEdit;
    BtnSendAll: TButton;
    eServer: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BtnSendAllClick(Sender: TObject);
    procedure BbtnAddToListClick(Sender: TObject);
    procedure BtnRemoveClick(Sender: TObject);
    procedure BtnFindClick(Sender: TObject);
    procedure MailSendStart(Sender: TObject);
    procedure MailSuccess(Sender: TObject);
    procedure MailFailure(Sender: TObject);
    procedure MailConnect(Sender: TObject);
    procedure MailDisconnect(Sender: TObject);
  private
    FileName: string;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  // load the list of addresses
  FileName := ChangeFileExt (Application.ExeName, '.txt');
  ListAddr.Items.LoadFromFile (FileName);
  ListLog.Items.Add ('Addresses: ' + IntToStr (
    ListAddr.Items.Count));
  // select the first item
  ListAddr.ItemIndex := 0;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // save the list of addresses
  ListAddr.Items.SaveToFile (FileName);
end;

const
  BccInMsg = 30;

procedure TMainForm.BtnSendAllClick(Sender: TObject);
var
  nItem, nBcc: Integer;
  Res: Word;
begin
  Res := MessageDlg ('Start sending from item ' +
      IntToStr (ListAddr.ItemIndex) + ' (' +
      ListAddr.Items [ListAddr.ItemIndex] + ')?'#13 +
      '(No starts form 0)',
      mtConfirmation,
      [mbYes, mbNo, mbCancel], 0);
  if Res = mrCancel then
    Exit;
  if Res = mrYes then
    nItem := ListAddr.ItemIndex
  else
    nItem := 0;

  // connect
  Mail.Host := eServer.Text;
  Mail.UserID := eFrom.Text;
  Mail.Connect;

  // set the fixed part of the header
  Mail.PostMessage.FromAddress := eFrom.Text;
  Mail.PostMessage.ToAddress.Clear;
  Mail.PostMessage.ToAddress.Add (eFrom.Text);
  Mail.PostMessage.Subject := eSubject.Text;
  Mail.PostMessage.Body.SetText (
    reMessageText.Lines.GetText);

  // send to list, in groups
  while nItem < ListAddr.Items.Count do
  begin
    // show the current selection
    ListAddr.ItemIndex := nItem;
    Application.ProcessMessages;

    // fill the bcc list
    Mail.PostMessage.ToBlindCarbonCopy.Clear;
    nBcc := 0;
    while (nBcc < BccInMsg) and (nBcc + nItem < ListAddr.Items.Count) do
    begin
      Mail.PostMessage.ToBlindCarbonCopy.Add (ListAddr.Items [nItem + nBcc]);
      Inc (nBcc);
    end;

    // send the message
    Mail.SendMail;

    // increse the counter
    Inc (nItem, nBcc);
  end;

  // we're done
  Mail.Disconnect;
end;

procedure TMainForm.BbtnAddToListClick(Sender: TObject);
begin
  ListAddr.ItemIndex :=
    ListAddr.Items.Add (eName.Text);
end;

procedure TMainForm.BtnRemoveClick(Sender: TObject);
begin
  // copy the item to the name edit box and remove it
  eName.Text := ListAddr.Items [ListAddr.ItemIndex];
  ListAddr.Items.Delete (ListAddr.ItemIndex);
end;

procedure TMainForm.BtnFindClick(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to ListAddr.Items.Count - 1 do
    if Pos (eName.Text, ListAddr.Items [I]) > 0 then
    begin
      ListAddr.ItemIndex := I;
      Break;
    end;
  Beep;
end;

procedure TMainForm.MailSendStart(Sender: TObject);
begin
  ListLog.Items.Add ('Sending to group: ' +
    Mail.PostMessage.ToBlindCarbonCopy [0]);
end;

procedure TMainForm.MailSuccess(Sender: TObject);
begin
  ListLog.Items.Add ('Done');
end;

procedure TMainForm.MailFailure(Sender: TObject);
begin
  ListLog.Items.Add ('Error');
end;

procedure TMainForm.MailConnect(Sender: TObject);
begin
  ListLog.Items.Add ('Connected to host');
end;

procedure TMainForm.MailDisconnect(Sender: TObject);
begin
  ListLog.Items.Add ('Disconnected for host');
end;

end.

SENDFORM.DFM

object MainForm: TMainForm
  Left = 193
  Top = 109
  AutoScroll = False
  Caption = 'Send List'
  ClientHeight = 501
  ClientWidth = 593
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  Position = poDefaultPosOnly
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Splitter1: TSplitter
    Left = 321
    Top = 241
    Width = 3
    Height = 260
    Cursor = crHSplit
  end
  object Panel1: TPanel
    Left = 0
    Top = 30
    Width = 593
    Height = 211
    Align = alTop
    BevelOuter = bvLowered
    TabOrder = 2
    object Label1: TLabel
      Left = 12
      Top = 11
      Width = 31
      Height = 13
      Hint = 'Recipient''s name(s), comma delimited'
         Caption = 'Name:'
      ParentShowHint = False
      ShowHint = True
    end
    object Label3: TLabel
      Left = 12
      Top = 34
      Width = 19
      Height = 13
      Caption = 'List:'
    end
    object eName: TEdit
      Left = 48
      Top = 7
      Width = 441
      Height = 21
      ParentShowHint = False
      ShowHint = False
      TabOrder = 0
    end
    object BbtnAddToList: TButton
      Left = 504
      Top = 32
      Width = 75
      Height = 25
      Caption = 'Add To &List'
      TabOrder = 1
      OnClick = BbtnAddToListClick
    end
    object ListAddr: TListBox
      Left = 48
      Top = 32
      Width = 441
      Height = 169
      ItemHeight = 13
      Sorted = True
      TabOrder = 2
    end
    object BtnRemove: TButton
      Left = 504
      Top = 72
      Width = 75
      Height = 25
      Caption = '&Remove'
      TabOrder = 3
      OnClick = BtnRemoveClick
    end
    object BtnFind: TButton
      Left = 504
      Top = 112
      Width = 75
      Height = 25
      Caption = '&Find'
      TabOrder = 4
      OnClick = BtnFindClick
    end
    object BtnSendAll: TButton
      Left = 504
      Top = 152
      Width = 75
      Height = 25
      Caption = 'Send to &All'
      TabOrder = 5
      OnClick = BtnSendAllClick
    end
  end
  object reMessageText: TRichEdit
    Left = 0
    Top = 241
    Width = 321
    Height = 260
    Align = alLeft
    Lines.Strings = (
      'This is a test message.'
      ''
      'Message sent by the Send List program '
      'of the book Mastering Delphi.')
    TabOrder = 1
  end
  object Panel2: TPanel
    Left = 0
    Top = 0
    Width = 593
    Height = 30
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 0
    object Label2: TLabel
      Left = 11
      Top = 8
      Width = 39
      Height = 13
      Hint = 'Subject of this message'
      Caption = 'Subject:'
      ParentShowHint = False
      ShowHint = True
    end
    object Label5: TLabel
      Left = 208
      Top = 8
      Width = 44
      Height = 13
      Caption = 'From/To:'
    end
    object eSubject: TEdit
      Left = 53
      Top = 4
      Width = 148
      Height = 21
      TabOrder = 0
    end
    object eFrom: TEdit
      Left = 256
      Top = 3
      Width = 153
      Height = 21
      TabOrder = 1
    end
    object eServer: TEdit
      Left = 463
      Top = 4
      Width = 121
      Height = 21
      TabOrder = 2
    end
  end
  object ListLog: TListBox
    Left = 324
    Top = 241
    Width = 269
    Height = 260
    Align = alClient
    ItemHeight = 13
    TabOrder = 3
  end
  object Mail: TNMSMTP
    Port = 25
    ReportLevel = 0
    OnDisconnect = MailDisconnect
    OnConnect = MailConnect
    EncodeType = uuMime
    ClearParams = False
    SubType = mtPlain
    OnSendStart = MailSendStart
    OnSuccess = MailSuccess
    OnFailure = MailFailure
    Left = 72
    Top = 78
  end
end


Copyright Marco Cantù 1998