Home: Code Repository: Mastering Delphi 5

Project THREADDB

Project Structure

THREADDB.DPR
FORMDBTHREAD.PAS
THREADEDMODULE.PAS
DBTHREADCLASS.PAS
FORMDBTHREAD.DFM
THREADEDMODULE.DFM

program ThreadDB;

uses
  Forms,
  formDbthread in 'formDbthread.pas' {Form1},
  threadedmodule in 'threadedmodule.pas' {DataModule2: TDataModule},
  dbthreadclass in 'dbthreadclass.pas';

{$R *.RES}

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

unit formDbThread;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, Grids, DBGrids, DBTables, StdCtrls, dbthreadclass, ExtCtrls;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    Table1CustNo: TFloatField;
    Table1Company: TStringField;
    Table1Addr1: TStringField;
    Table1Addr2: TStringField;
    Table1City: TStringField;
    Table1State: TStringField;
    Table1Zip: TStringField;
    Table1Country: TStringField;
    Table1Phone: TStringField;
    Table1FAX: TStringField;
    Table1TaxRate: TFloatField;
    Table1Contact: TStringField;
    Table1LastInvoiceDate: TDateTimeField;
    ListBox1: TListBox;
    Splitter1: TSplitter;
    procedure FormCreate(Sender: TObject);
    procedure Table1AfterScroll(DataSet: TDataSet);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Table1.Active := True;
end;

procedure TForm1.Table1AfterScroll(DataSet: TDataSet);
var
  Th1: TDatabaseThread;
begin
  // create and start a new thread
  Th1 := TDatabaseThread.Create (True);
  Th1.Priority := tpLowest;
  Th1.FreeOnTerminate := True;
  Th1.CustNo := Table1CustNo.AsInteger;
  Th1.Resume;
end;

end.

unit threadedmodule;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables;

type
  TDataModule2 = class(TDataModule)
    Session1: TSession;
    Database1: TDatabase;
    Query1: TQuery;
    Query1COUNT: TIntegerField;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

implementation

{$R *.DFM}

end.

unit dbthreadclass;

interface

uses
  Classes, Windows;

type
  TDatabaseThread = class(TThread)
  private
    { Private declarations }
    NewCaption: string;
    LogText: string;
    FCustNo: Integer;
    procedure SetCustNo(const Value: Integer);
  protected
    procedure Execute; override;
    procedure UpdateCaption;
    procedure AddToLog;
  public
    property CustNo: Integer read FCustNo write SetCustNo;
  end;

var
  thcount: Integer = 0;
  hSemaphore: THandle;

implementation

uses
  FormDbThread, ThreadedModule, SysUtils;

procedure TDatabaseThread.UpdateCaption;
begin
  Form1.Caption := NewCaption;
end;

procedure TDatabaseThread.Execute;
begin
  // log
  Inc (thcount);
  LogText := Format ('Thread %d started (%d active)',
    [CustNo, thcount]);
  Synchronize (AddToLog);

  WaitForSingleobject (hSemaphore, 100000);
  try
    with TDataModule2.Create (nil) do
    begin
      try
        Query1.ParamByName('Cust').AsInteger := CustNo;
        Query1.Open;
        NewCaption := 'Number of Orders ' +
          Query1Count.AsString;
      finally
        Synchronize (UpdateCaption);
        Query1.Close;
        Free; // the data module

        // log
        Dec (thcount);
        LogText := Format ('Thread %d completed (%d active)',
          [CustNo, thcount]);
        Synchronize (AddToLog);
      end;
    end;
  finally
    ReleaseSemaphore (hSemaphore, 1, nil);
  end;
end;

procedure TDatabaseThread.SetCustNo(const Value: Integer);
begin
  FCustNo := Value;
end;

procedure TDatabaseThread.AddToLog;
begin
  with Form1.ListBox1 do
    ItemIndex := Items.Add (LogText);
end;

initialization
  hSemaphore := CreateSemaphore (
    nil, 10, 10, 'ThDB_MD_Semaphore');
end.

object Form1: TForm1
  Left = 199
  Top = 226
  Width = 781
  Height = 250
  Caption = 'ThDB'
  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 Splitter1: TSplitter
    Left = 545
    Top = 0
    Width = 3
    Height = 223
    Cursor = crHSplit
  end
  object DBGrid1: TDBGrid
    Left = 0
    Top = 0
    Width = 545
    Height = 223
    Align = alLeft
    DataSource = DataSource1
    TabOrder = 0
    TitleFont.Charset = DEFAULT_CHARSET
    TitleFont.Color = clWindowText
    TitleFont.Height = -11
    TitleFont.Name = 'MS Sans Serif'
    TitleFont.Style = []
  end
  object ListBox1: TListBox
    Left = 548
    Top = 0
    Width = 225
    Height = 223
    Align = alClient
    ItemHeight = 13
    TabOrder = 1
  end
  object Table1: TTable
    AutoCalcFields = False
    AfterScroll = Table1AfterScroll
    DatabaseName = 'DBDEMOS'
    TableName = 'customer.db'
    Left = 24
    Top = 56
    object Table1CustNo: TFloatField
      Alignment = taLeftJustify
      CustomConstraint = 'CustNo IS NOT NULL'
      ConstraintErrorMessage = 'CustNo cannot be blank'
      FieldName = 'CustNo'
      DisplayFormat = 'CN 0000'
      MaxValue = 9999
      MinValue = 1000
    end
    object Table1Company: TStringField
      CustomConstraint = 'X IS NOT NULL'
      ConstraintErrorMessage = 'Company Field has to have a value'
      FieldName = 'Company'
      FixedChar = False
      Size = 30
    end
    object Table1Addr1: TStringField
      FieldName = 'Addr1'
      FixedChar = False
      Size = 30
    end
    object Table1Addr2: TStringField
      FieldName = 'Addr2'
      FixedChar = False
      Size = 30
    end
    object Table1City: TStringField
      FieldName = 'City'
      FixedChar = False
      Size = 15
    end
    object Table1State: TStringField
      FieldName = 'State'
      FixedChar = False
    end
    object Table1Zip: TStringField
      FieldName = 'Zip'
      FixedChar = False
      Size = 10
    end
    object Table1Country: TStringField
      FieldName = 'Country'
      FixedChar = False
    end
    object Table1Phone: TStringField
      FieldName = 'Phone'
      FixedChar = False
      Size = 15
    end
    object Table1FAX: TStringField
      FieldName = 'FAX'
      FixedChar = False
      Size = 15
    end
    object Table1TaxRate: TFloatField
      FieldName = 'TaxRate'
      DisplayFormat = '0.00%'
      MaxValue = 100
    end
    object Table1Contact: TStringField
      FieldName = 'Contact'
      FixedChar = False
    end
    object Table1LastInvoiceDate: TDateTimeField
      FieldName = 'LastInvoiceDate'
    end
  end
  object DataSource1: TDataSource
    DataSet = Table1
    Left = 24
    Top = 104
  end
end

object DataModule2: TDataModule2
  OldCreateOrder = True
  Left = 212
  Top = 167
  Height = 454
  Width = 715
  object Session1: TSession
    Active = True
    AutoSessionName = True
    Left = 24
    Top = 16
  end
  object Database1: TDatabase
    AliasName = 'DBDEMOS'
    Connected = True
    DatabaseName = 'mydb'
    Params.Strings = (
      'USER NAME=SYSDBA')
    SessionName = 'Session1_2'
    Left = 24
    Top = 64
  end
  object Query1: TQuery
    DatabaseName = 'mydb'
    SessionName = 'Session1_2'
    SQL.Strings = (
      'select count (*) '
      'from orders'
      'where CustNo = :Cust;')
    Left = 72
    Top = 16
    ParamData = <
      item
        DataType = ftInteger
        Name = 'Cust'
        ParamType = ptUnknown
      end>
    object Query1COUNT: TIntegerField
      FieldName = 'COUNT(*)'
    end
  end
end