Home: Code Repository: Mastering Delphi 5

Project SERVERDB

Project Structure

SERVERDB.DPR
SERVERFORM.PAS
SERVERFORM.DFM

program ServerDb;

uses
  Forms,
  ServerForm in 'ServerForm.pas' {Form1};

{$R *.RES}

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

unit ServerForm;

interface

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

const
  wm_RefreshClients = wm_User;

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Label1: TLabel;
    lbClients: TListBox;
    lbLog: TListBox;
    ServerSocket1: TServerSocket;
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    Table1Company: TStringField;
    Table1CompID: TFloatField;
    Table1Address: TStringField;
    Table1State: TStringField;
    Table1Country: TStringField;
    Table1Email: TStringField;
    Table1Contact: TStringField;
    Table1LoggedBy: TStringField;
    Table1LoggetOn: TDateField;
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure ServerSocket1ClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
  private
    { Private declarations }
  public
    procedure RefreshClients (var Msg: TMessage);
      message wm_RefreshClients;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  lbLog.Items.Add ('Connected: ' +
    Socket.RemoteHost + ' (' +
    Socket.RemoteAddress + ')' );
  PostMessage (Handle, wm_RefreshClients, 0, 0);
end;

procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  lbLog.Items.Add ('Disconnected: ' +
    Socket.RemoteHost + ' (' +
    Socket.RemoteAddress + ')' );
  PostMessage (Handle, wm_RefreshClients, 0, 0);
end;

procedure TForm1.RefreshClients;
var
  I: Integer;
begin
  lbClients.Clear;
  for I := 0 to ServerSocket1.Socket.ActiveConnections - 1 do
    with ServerSocket1.Socket.Connections [I] do
      lbClients.Items.Add (
        RemoteAddress + ' (' + RemoteHost + ')');
end;

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

procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  strCommand: string;
  strFeedback: string;
  Data: TStringList;
  I: Integer;
begin
  // read from the client
  strCommand := Socket.ReceiveText;
  lbLog.Items.Add (strCommand);

  // reassemble the data
  Data := TStringList.Create;
  try
    Data.Text := strCommand;
    // new record
    Table1.Insert;
    // set the fields using the strings
    for I := 0 to Table1.FieldCount - 1 do
      Table1.Fields [I].AsString :=
        Data.Values [Table1.Fields[I].FieldName];
    // complete with random ID, sender, and date
    Table1CompID.AsInteger := GetTickCount;
    Table1LoggedBy.AsString := Socket.RemoteAddress;
    Table1LoggetOn.AsDateTime := Date;
    Table1.Post;

    // get the value to return
    strFeedback := Table1CompID.AsString;

    // send results back
    lbLog.Items.Add (strFeedback);
    Socket.SendText (strFeedback);
  finally
    Data.Free;
  end;
end;

end.

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 536
  Height = 396
  Caption = 'Server'
  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 PageControl1: TPageControl
    Left = 0
    Top = 0
    Width = 528
    Height = 369
    ActivePage = TabSheet1
    Align = alClient
    TabOrder = 0
    object TabSheet1: TTabSheet
      Caption = 'Connections'
      object Label1: TLabel
        Left = 16
        Top = 8
        Width = 31
        Height = 13
        Caption = 'Clients'
      end
      object lbClients: TListBox
        Left = 16
        Top = 24
        Width = 161
        Height = 297
        ItemHeight = 13
        TabOrder = 0
      end
      object lbLog: TListBox
        Left = 184
        Top = 24
        Width = 313
        Height = 298
        ItemHeight = 13
        TabOrder = 1
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'Database'
      object DBGrid1: TDBGrid
        Left = 0
        Top = 0
        Width = 520
        Height = 341
        Align = alClient
        DataSource = DataSource1
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'MS Sans Serif'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Company'
            Width = 175
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'CompID'
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Address'
            Width = 130
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'State'
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Country'
            Width = 89
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Email'
            Width = 116
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'Contact'
            Width = 88
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'LoggedBy'
            Width = 83
            Visible = True
          end
          item
            Expanded = False
            FieldName = 'LoggetOn'
            Visible = True
          end>
      end
    end
  end
  object ServerSocket1: TServerSocket
    Active = True
    Port = 51
    ServerType = stNonBlocking
    OnClientConnect = ServerSocket1ClientConnect
    OnClientDisconnect = ServerSocket1ClientDisconnect
    OnClientRead = ServerSocket1ClientRead
    Left = 40
    Top = 48
  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
      item
        Name = 'LoggedBy'
        DataType = ftString
        Size = 40
      end
      item
        Name = 'LoggetOn'
        DataType = ftDate
      end>
    StoreDefs = True
    TableName = 'ServDb.db'
    Left = 36
    Top = 104
    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
    object Table1LoggedBy: TStringField
      FieldName = 'LoggedBy'
      Size = 40
    end
    object Table1LoggetOn: TDateField
      FieldName = 'LoggetOn'
    end
  end
  object DataSource1: TDataSource
    DataSet = Table1
    Left = 36
    Top = 160
  end
end