Project Structure

• Server2.dpr
• ServerForm.pas
• ServerForm.dfm

program Server2;

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

{$R *.RES}

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

unit ServerForm;

interface

{$WARN UNIT_PLATFORM OFF}

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.

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