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 ClientDbThread

Project Structure

ClientDbThread.dpr
program ClientDbThread;

uses
  Forms,
  ClientForm in 'ClientForm.pas' {Form1},
  ClientThread in 'ClientThread.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
ClientForm.pas
unit ClientForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DBCtrls, ExtCtrls, Db, Mask, DBTables, ScktComp;

type
  TForm1 = class(TForm)
    EditServer: TEdit;
    Server: TLabel;
    Table1: TTable;
    Table1Company: TStringField;
    Table1CompID: TFloatField;
    Table1Address: TStringField;
    Table1State: TStringField;
    Table1Country: TStringField;
    Table1Email: TStringField;
    Table1Contact: TStringField;
    Label1: TLabel;
    DBEdit1: TDBEdit;
    DataSource1: TDataSource;
    Label2: TLabel;
    Label3: TLabel;
    DBEdit3: TDBEdit;
    Label4: TLabel;
    DBEdit4: TDBEdit;
    Label5: TLabel;
    DBEdit5: TDBEdit;
    Label6: TLabel;
    DBEdit6: TDBEdit;
    Label7: TLabel;
    DBEdit7: TDBEdit;
    DBNavigator1: TDBNavigator;
    DBText1: TDBText;
    lbLog: TListBox;
    BtnDelete: TButton;
    Label8: TLabel;
    Bevel1: TBevel;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure BtnDeleteClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure OnLog(Sender: TObject; LogMsg: String);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  ClientThread;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // use a table in the current directory
  Table1.DatabaseName :=
    ExtractFilePath (Application.ExeName);
  // create it if it doesn't exist
  if not Table1.Exists then
    Table1.CreateTable;
  Table1.Active := True;

end;

procedure TForm1.BtnDeleteClick(Sender: TObject);
begin
  table1.First;
  while not Table1.Eof do
  begin
    // if the record is still logged
    if not Table1CompID.IsNull and (Table1CompId.AsInteger <> 0) then
      Table1.Delete;
    Table1.Next;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  SendThread: TSendThread;
begin
  SendThread := TSendThread.Create(Table1);
  SendThread.OnLog := OnLog;
  SendThread.ServerAddress := EditServer.Text;
  SendThread.Resume;
end;

procedure TForm1.OnLog(Sender: TObject; LogMsg: String);
begin
  lbLog.Items.Add(LogMsg);
end;

end.
ClientThread.pas
unit ClientThread;

interface

uses
  Classes, ScktComp, DBTables;

type
  TLogEvent = procedure(Sender: TObject; LogMsg: String) of object;

  TSendThread = class(TThread)
  private
    ClientSocket: TClientSocket;
    FTable: TTable;
    FOnLog: TLogEvent;
    FLogMsg: String;
    FServerAddress: string;
    procedure SetOnLog(const Value: TLogEvent);
    procedure SetServerAddress(const Value: string);
  protected
    procedure Execute; override;
    procedure DoLog;
  public
    constructor Create(ATable: TTable);
    property OnLog: TLogEvent read FOnLog write SetOnLog;
    property ServerAddress: string read FServerAddress write SetServerAddress;
  end;

implementation

uses
  ClientForm;

constructor TSendThread.Create(ATable: TTable);
begin
  FTable := ATable;
  inherited Create(True);
  FreeOnTerminate := True;
end;

procedure TSendThread.DoLog;
begin
  if Assigned(FOnLog) then
    FOnLog(self, FLogMsg);
end;

procedure TSendThread.Execute;
var
  I: Integer;
  Data: TStringList;
  Stream: TWinSocketStream;
  Buf: String;
begin
  try
    Data := TStringList.Create;
    ClientSocket := TClientSocket.Create (nil);
    Stream := nil;
    try
      ClientSocket.Address := ServerAddress;
      ClientSocket.ClientType := ctBlocking;
      ClientSocket.Port := 51;
      ClientSocket.Active := True;
      Stream := TWinSocketStream.Create(ClientSocket.Socket, 30000);

      FTable.First;
      while not FTable.Eof do
      begin
        // if the record is still not logged
        if FTable.FieldByName('CompID').IsNull or (FTable.FieldByName('CompID').AsInteger = 0) then
        begin
          FLogMsg := 'Sending ' + FTable.FieldByName('Company').AsString;
          Synchronize(DoLog);
          Data.Clear;
          // create strings with structure "FieldName=Value"
          for I := 0 to FTable.FieldCount - 1 do
            Data.Values [FTable.Fields[I].FieldName] :=
              FTable.Fields [I].AsString;
          // send the record
          Buf := Data.Text + #10#13'.'#10#13;
          ClientSocket.Socket.SendText(Buf);
          // wait for reponse
          if Stream.WaitForData(30000) then
          begin
            FTable.Edit;
            SetLength(Buf, 256);
            SetLength(Buf, Stream.Read(Buf[1], Length(Buf)));

            FTable.FieldByName('CompID').AsString := Buf;
            FTable.Post;
            FLogMsg := FTable.FieldByName('Company').AsString +
              ' logged as ' + FTable.FieldByName('CompID').AsString;
          end
          else
            FlogMsg := 'No response for ' + FTable.FieldByName('Company').AsString;
          Synchronize(DoLog);
        end;
        FTable.Next;
      end;
    finally
      ClientSocket.Active := False;
      ClientSocket.Free;
      Stream.Free;
      Data.Free;
    end;
  except
    // trap exceptions
  end;
end;

procedure TSendThread.SetOnLog(const Value: TLogEvent);
begin
  FOnLog := Value;
end;

procedure TSendThread.SetServerAddress(const Value: string);
begin
  FServerAddress := Value;
end;

end.
ClientForm.dfm
object Form1: TForm1
  Left = 349
  Top = 122
  Width = 581
  Height = 430
  Caption = 'Client'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Bevel1: TBevel
    Left = 16
    Top = 72
    Width = 337
    Height = 313
  end
  object Server: TLabel
    Left = 16
    Top = 16
    Width = 31
    Height = 13
    Caption = 'Server'
  end
  object Label1: TLabel
    Left = 32
    Top = 152
    Width = 44
    Height = 13
    Caption = 'Company'
    FocusControl = DBEdit1
  end
  object Label2: TLabel
    Left = 32
    Top = 128
    Width = 38
    Height = 13
    Caption = 'CompID'
  end
  object Label3: TLabel
    Left = 32
    Top = 200
    Width = 38
    Height = 13
    Caption = 'Address'
    FocusControl = DBEdit3
  end
  object Label4: TLabel
    Left = 32
    Top = 240
    Width = 25
    Height = 13
    Caption = 'State'
    FocusControl = DBEdit4
  end
  object Label5: TLabel
    Left = 96
    Top = 240
    Width = 36
    Height = 13
    Caption = 'Country'
    FocusControl = DBEdit5
  end
  object Label6: TLabel
    Left = 32
    Top = 288
    Width = 25
    Height = 13
    Caption = 'Email'
    FocusControl = DBEdit6
  end
  object Label7: TLabel
    Left = 32
    Top = 328
    Width = 37
    Height = 13
    Caption = 'Contact'
    FocusControl = DBEdit7
  end
  object DBText1: TDBText
    Left = 80
    Top = 128
    Width = 65
    Height = 17
    DataField = 'CompID'
    DataSource = DataSource1
  end
  object Label8: TLabel
    Left = 368
    Top = 120
    Width = 21
    Height = 13
    Caption = 'Log:'
  end
  object EditServer: TEdit
    Left = 56
    Top = 13
    Width = 121
    Height = 21
    TabOrder = 0
    Text = '127.0.0.1'
  end
  object DBEdit1: TDBEdit
    Left = 32
    Top = 168
    Width = 304
    Height = 21
    DataField = 'Company'
    DataSource = DataSource1
    TabOrder = 1
  end
  object DBEdit3: TDBEdit
    Left = 32
    Top = 216
    Width = 305
    Height = 21
    DataField = 'Address'
    DataSource = DataSource1
    TabOrder = 2
  end
  object DBEdit4: TDBEdit
    Left = 32
    Top = 256
    Width = 49
    Height = 21
    DataField = 'State'
    DataSource = DataSource1
    TabOrder = 3
  end
  object DBEdit5: TDBEdit
    Left = 96
    Top = 256
    Width = 241
    Height = 21
    DataField = 'Country'
    DataSource = DataSource1
    TabOrder = 4
  end
  object DBEdit6: TDBEdit
    Left = 32
    Top = 304
    Width = 305
    Height = 21
    DataField = 'Email'
    DataSource = DataSource1
    TabOrder = 5
  end
  object DBEdit7: TDBEdit
    Left = 32
    Top = 344
    Width = 305
    Height = 21
    DataField = 'Contact'
    DataSource = DataSource1
    TabOrder = 6
  end
  object DBNavigator1: TDBNavigator
    Left = 40
    Top = 88
    Width = 240
    Height = 25
    DataSource = DataSource1
    TabOrder = 7
  end
  object lbLog: TListBox
    Left = 368
    Top = 136
    Width = 185
    Height = 249
    ItemHeight = 13
    TabOrder = 8
  end
  object BtnDelete: TButton
    Left = 408
    Top = 16
    Width = 105
    Height = 25
    Caption = '&Delete All Sent'
    TabOrder = 9
    OnClick = BtnDeleteClick
  end
  object Button2: TButton
    Left = 408
    Top = 48
    Width = 105
    Height = 25
    Caption = 'Send All (&Thread)'
    TabOrder = 10
    OnClick = Button2Click
  end
  object Table1: TTable
    FieldDefs = <
      item
        Name = 'Company'
        DataType = ftString
        Size = 50
      end
      item
        Name = 'CompID'
        DataType = ftFloat
      end
      item
        Name = 'Address'
        DataType = ftString
        Size = 100
      end
      item
        Name = 'State'
        DataType = ftString
        Size = 2
      end
      item
        Name = 'Country'
        DataType = ftString
        Size = 20
      end
      item
        Name = 'Email'
        DataType = ftString
        Size = 40
      end
      item
        Name = 'Contact'
        DataType = ftString
        Size = 40
      end>
    StoreDefs = True
    TableName = 'clientdb.DB'
    Left = 220
    Top = 32
    object Table1Company: TStringField
      FieldName = 'Company'
      Size = 50
    end
    object Table1CompID: TFloatField
      FieldName = 'CompID'
    end
    object Table1Address: TStringField
      FieldName = 'Address'
      Size = 100
    end
    object Table1State: TStringField
      FieldName = 'State'
      Size = 2
    end
    object Table1Country: TStringField
      FieldName = 'Country'
    end
    object Table1Email: TStringField
      FieldName = 'Email'
      Size = 40
    end
    object Table1Contact: TStringField
      FieldName = 'Contact'
      Size = 40
    end
  end
  object DataSource1: TDataSource
    DataSet = Table1
    Left = 96
    Top = 35
  end
end