Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 21 - Project SendList

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, IdComponent, IdTCPConnection, IdTCPClient,
  IdMessageClient, IdSMTP, IdBaseComponent, IdMessage;

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;
    Label5: TLabel;
    eFrom: TEdit;
    BtnSendAll: TButton;
    eServer: TEdit;
    MailMessage: TIdMessage;
    Mail: TIdSMTP;
    Label4: TLabel;
    Label6: TLabel;
    eUserName: TEdit;
    Password: TLabel;
    ePassword: 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 MailConnected(Sender: TObject);
    procedure MailDisconnected(Sender: TObject);
    procedure MailStatus(axSender: TObject; const axStatus: TIdStatus;
      const asStatusText: String);
    procedure MailWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure MailWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
  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: 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 := eUserName.Text;
  if ePassword.Text <> '' then
  begin
    Mail.Password := ePassword.Text;
    Mail.AuthenticationType := atLogin;
  end;
  Mail.Connect;

  // send the messages, one by one, prepending a custom message
  try
    // set the fixed part of the header
    MailMessage.From.Name := eFrom.Text;
    MailMessage.Subject := eSubject.Text;
    MailMessage.Body.SetText (
      reMessageText.Lines.GetText);
    MailMessage.Body.Insert (0, 'Hello');

    while nItem < ListAddr.Items.Count do
    begin
      // show the current selection
      Application.ProcessMessages;
      ListAddr.ItemIndex := nItem;
      MailMessage.Body [0] := 'Hello ' + ListAddr.Items [nItem];
      MailMessage.Recipients.EMailAddresses := ListAddr.Items [nItem];
      Mail.Send(MailMessage);
      Inc (nItem);
    end;
  finally // we're done
    Mail.Disconnect;
  end;
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.MailConnected(Sender: TObject);
begin
  ListLog.Items.Add ('Connected to host');
end;

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

procedure TMainForm.MailStatus(axSender: TObject;
  const axStatus: TIdStatus; const asStatusText: String);
begin
  ListLog.Items.Add (asStatusText);
end;

procedure TMainForm.MailWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  ListLog.Items.Add ('Sending to: ' +
    MailMessage.Recipients.EMailAddresses);
end;

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

end.
SendForm.dfm
object MainForm: TMainForm
  Left = 193
  Top = 109
  AutoScroll = False
  Caption = 'Send List'
  ClientHeight = 501
  ClientWidth = 622
  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 = 276
    Width = 3
    Height = 225
    Cursor = crHSplit
  end
  object Panel1: TPanel
    Left = 0
    Top = 65
    Width = 622
    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 = 276
    Width = 321
    Height = 225
    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 = 622
    Height = 65
    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 = 16
      Top = 40
      Width = 26
      Height = 13
      Caption = 'From:'
    end
    object Label4: TLabel
      Left = 264
      Top = 8
      Width = 25
      Height = 13
      Caption = 'Host:'
    end
    object Label6: TLabel
      Left = 240
      Top = 37
      Width = 53
      Height = 13
      Caption = 'UserName:'
    end
    object Password: TLabel
      Left = 426
      Top = 37
      Width = 49
      Height = 13
      Caption = 'Password:'
    end
    object eSubject: TEdit
      Left = 56
      Top = 4
      Width = 153
      Height = 21
      TabOrder = 0
    end
    object eFrom: TEdit
      Left = 56
      Top = 35
      Width = 153
      Height = 21
      TabOrder = 1
    end
    object eServer: TEdit
      Left = 295
      Top = 4
      Width = 121
      Height = 21
      TabOrder = 2
    end
    object eUserName: TEdit
      Left = 296
      Top = 32
      Width = 121
      Height = 21
      TabOrder = 3
    end
    object ePassword: TEdit
      Left = 480
      Top = 32
      Width = 121
      Height = 21
      PasswordChar = '*'
      TabOrder = 4
    end
  end
  object ListLog: TListBox
    Left = 324
    Top = 276
    Width = 298
    Height = 225
    Align = alClient
    ItemHeight = 13
    TabOrder = 3
  end
  object MailMessage: TIdMessage
    BccList = <>
    CCList = <>
    Recipients = <>
    ReplyTo = <>
    Left = 144
    Top = 80
  end
  object Mail: TIdSMTP
    OnStatus = MailStatus
    OnDisconnected = MailDisconnected
    OnWorkBegin = MailWorkBegin
    OnWorkEnd = MailWorkEnd
    OnConnected = MailConnected
    Left = 144
    Top = 120
  end
end