Project SERVERDB
Project Structure
SERVERDB.DPR
program ServerDb;
uses
Forms,
ServerForm in 'ServerForm.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
SERVERFORM.PAS
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.
SERVERFORM.DFM
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
|
