Project Structure

• ClientDbThread.dpr
• ClientForm.pas
• ClientThread.pas
• ClientForm.dfm

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.

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.

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.

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