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 5

Project SERVER2

Project Structure


SERVER2.DPR

program Server2;

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, FileCtrl;

const
  wm_RefreshClients = wm_User;

type
  TForm1 = class(TForm)
    ServerSocket1: TServerSocket;
    lbClients: TListBox;
    Label1: TLabel;
    Label2: TLabel;
    lbLog: TListBox;
    FileListBox1: TFileListBox;
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
  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 + ')' );
end;

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

procedure TForm1.RefreshClients;
begin
end;

procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  strCommand, strFile, strFeedback: string;
begin
  // read from the client
  strCommand := Socket.ReceiveText;
  lbLog.Items.Add ('Client: ' + Socket.RemoteAddress + ': ' +
    strCommand);
  // extract the file name (all commands have 5 characters)
  strFile := Copy (strCommand, 6, Length (strCommand) - 5);

  // execute program
  if Pos ('EXEC!', strCommand) = 1 then
  begin
    if FileExists (strFile) and (
        WinExec (pChar (strFile), sw_ShowNormal) > 31) then
      strFeedback := 'ERROR' + strFile + ' activated'
    else
      strFeedback := 'ERROR' + strFile + ' not found';
    Socket.SendText (strFeedback);
  end

    // send back a text file
  else if Pos ('TEXT!', strCommand) = 1 then
  begin
    if FileExists (strFile) then
    begin
      strFeedback := 'TEXT!';
      Socket.SendText (strFeedback);
      Socket.SendStream (TFileStream.Create (
        strFile, fmOpenRead or fmShareDenyWrite));
    end
    else
    begin
      strFeedback := 'ERROR' + strFile + ' not found';
      Socket.SendText (strFeedback);
    end;
  end

  // send back a bitmap file
  else if Pos ('BITM!', strCommand) = 1 then
  begin
    if FileExists (strFile) then
    begin
      strFeedback := 'BITM!';
      Socket.SendText (strFeedback);
      Socket.SendStream (TFileStream.Create (
        strFile, fmOpenRead or fmShareDenyWrite));
    end
    else
    begin
      strFeedback := 'ERROR' + strFile + ' not found';
      Socket.SendText (strFeedback);
    end;
  end

  // send back a directory listing
  else if Pos ('LIST!', strCommand) = 1 then
  begin
    if DirectoryExists (strFile) then
    begin
      strFeedback := 'LIST!';
      Socket.SendText (strFeedback);
      FileListBox1.Directory := strFile;
      Socket.SendText (FileListBox1.Items.Text);
    end
    else
    begin
      strFeedback := 'ERROR' + strFile + ' not found';
      Socket.SendText (strFeedback);
    end;
  end
  else
  begin
    strFeedback := 'ERROR' + 'Undefined command: ' + strCommand;
    Socket.SendText (strFeedback);
  end;

  // log result
  lbLog.Items.Add (strFeedback);
end;

end.

SERVERFORM.DFM

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 696
  Height = 283
  Caption = 'Server'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 16
    Top = 8
    Width = 31
    Height = 13
    Caption = 'Clients'
  end
  object Label2: TLabel
    Left = 192
    Top = 8
    Width = 18
    Height = 13
    Caption = 'Log'
  end
  object lbClients: TListBox
    Left = 16
    Top = 24
    Width = 161
    Height = 217
    ItemHeight = 13
    TabOrder = 0
  end
  object lbLog: TListBox
    Left = 192
    Top = 24
    Width = 481
    Height = 217
    ItemHeight = 13
    TabOrder = 1
  end
  object FileListBox1: TFileListBox
    Left = 200
    Top = 184
    Width = 169
    Height = 49
    ItemHeight = 13
    TabOrder = 2
    Visible = False
  end
  object ServerSocket1: TServerSocket
    Active = True
    Port = 51
    ServerType = stNonBlocking
    OnClientConnect = ServerSocket1ClientConnect
    OnClientDisconnect = ServerSocket1ClientDisconnect
    OnClientRead = ServerSocket1ClientRead
    Left = 72
    Top = 40
  end
end