unit MainForm;
interface
uses
Windows, Messages, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls,
ExtCtrls, ToolWin, ImgList, Spin, Menus, SysUtils, Classes, IdBaseComponent,
IdComponent, IdTCPServer, IdThreadMgr, IdThreadMgrDefault,
TFlatSplitterUnit, OleCtrls, SHDocVw_TLB, Buttons, IdTCPConnection,
IdTCPClient, IdHTTP;
type
TSimpleClient =
class(TObject)
DNS,
Name :
String;
ListLink : Integer;
Thread : Pointer;
end;
TfrmMain =
class(TForm)
StatusBar1: TStatusBar;
ImageList1: TImageList;
tcpServer: TIdTCPServer;
IdThreadMgrDefault1: TIdThreadMgrDefault;
puMemoMenu: TPopupMenu;
Savetofile1: TMenuItem;
Loadfromfile1: TMenuItem;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Panel2: TPanel;
PageControl2: TPageControl;
TabSheet1: TTabSheet;
lbClients: TListBox;
memEntry: TMemo;
ToolBar1: TToolBar;
btnServerUp: TToolButton;
Panel1: TPanel;
FlatSplitter1: TFlatSplitter;
Label1: TLabel;
Label2: TLabel;
TabSheet2: TTabSheet;
MainMenu1: TMainMenu;
Datei1: TMenuItem;
Beenden1: TMenuItem;
WebBrowser1: TWebBrowser;
TabSheet3: TTabSheet;
Panel3: TPanel;
Label3: TLabel;
edUsername: TEdit;
Label4: TLabel;
tbClients: TListBox;
memlines: TMemo;
edmessage: TEdit;
IdTCPClient1: TIdTCPClient;
Timer1: TTimer;
IdHTTP1: TIdHTTP;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
procedure btnServerUpClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure seBindingChange(Sender: TObject);
procedure tcpServerConnect(AThread: TIdPeerThread);
procedure tcpServerDisconnect(AThread: TIdPeerThread);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure Savetofile1Click(Sender: TObject);
procedure Loadfromfile1Click(Sender: TObject);
procedure tcpServerExecute(AThread: TIdPeerThread);
procedure btnClientsClick(Sender: TObject);
procedure btnPMClick(Sender: TObject);
procedure btnKillClientClick(Sender: TObject);
procedure Beenden1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure IdTCPClient1Connected(Sender: TObject);
procedure edmessageKeyPress(Sender: TObject;
var Key: Char);
procedure FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
procedure FormShow(Sender: TObject);
procedure ToolButton1Click(Sender: TObject);
procedure ToolButton2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Clients : TList;
procedure UpdateBindings;
procedure UpdateClientList;
procedure BroadcastMessage( WhoFrom, TheMessage :
String );
end;
var
frmMain: TfrmMain;
ip :
string;
status : integer;
implementation
{$R *.DFM}
{$R WinXP.res}
uses
IdSocketHandle;
// This is where the IdSocketHandle class is defined.
procedure TfrmMain.UpdateBindings;
var
Binding : TIdSocketHandle;
begin
{ Set the TIdTCPServer's port to the chosen value }
tcpServer.DefaultPort := 23;
{ Remove all bindings that currently exist }
tcpServer.Bindings.Clear;
{ Create a new binding }
Binding := tcpServer.Bindings.Add;
{ Assign that bindings port to our new port }
Binding.Port := 23;
end;
procedure TfrmMain.btnServerUpClick(Sender: TObject);
begin
try
{ Check to see if the server is online or offline }
tcpServer.Active :=
not tcpServer.Active;
btnServerUp.Down := tcpServer.Active;
if btnServerUp.Down
then
begin
{ Server is online }
btnServerUp.ImageIndex := 1;
btnServerUp.Hint := '
Shut down server';
end
else
begin
{ Server is offline }
btnServerUp.ImageIndex := 0;
btnServerUp.Hint := '
Start up server';
end;
{ Setup GUI buttons }
except
{ If we have a problem then rest things }
btnServerUp.Down := false;
end;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
Status := 0;
webbrowser1.navigate('
http://www.domain.de');
{ Initalize our clients list }
Clients := TList.Create;
{ Call updatebindings so that the servers bindings are correct }
UpdateBindings;
{ Get the local DNS entry for this computer }
{ Display the current version of indy running on the system }
end;
procedure TfrmMain.seBindingChange(Sender: TObject);
begin
UpdateBindings;
end;
procedure TfrmMain.tcpServerConnect(AThread: TIdPeerThread);
var
Client : TSimpleClient;
begin
{ Send a welcome message, and prompt for the users name }
AThread.Connection.WriteLn('
ISD Connection Established...');
AThread.Connection.WriteLn('
Please send valid login sequence...');
AThread.Connection.WriteLn('
Your Name:');
{ Create a client object }
Client := TSimpleClient.Create;
{ Assign its default values }
Client.DNS := AThread.Connection.LocalName;
Client.
Name := '
Logging In';
Client.ListLink := lbClients.Items.Count;
{ Assign the thread to it for ease in finding }
Client.Thread := AThread;
{ Add to our clients list box }
lbClients.Items.Add(Client.
Name);
{ Assign it to the thread so we can identify it later }
AThread.Data := Client;
{ Add it to the clients list }
Clients.Add(Client);
end;
procedure TfrmMain.tcpServerDisconnect(AThread: TIdPeerThread);
var
Client : TSimpleClient;
begin
{ Retrieve Client Record from Data pointer }
Client := Pointer(AThread.Data);
{ Remove Client from the Clients TList }
Clients.Delete(Client.ListLink);
{ Remove Client from the Clients List Box }
lbClients.Items.Delete(lbClients.Items.IndexOf(Client.
Name));
BroadcastMessage('
System', Client.
Name + '
has left the chat.');
{ Free the Client object }
Client.Free;
AThread.Data :=
nil;
end;
procedure TfrmMain.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
if (Clients.Count > 0)
and
(tcpServer.Active)
then
begin
Action := caNone;
ShowMessage('
Can''
t close CBServ while server is online.');
end
else
Clients.Free;
end;
procedure TfrmMain.Savetofile1Click(Sender: TObject);
begin
if not (puMemoMenu.PopupComponent
is TMemo)
then
exit;
if SaveDialog1.Execute
then
begin
TMemo(puMemoMenu.PopupComponent).Lines.SaveToFile(SaveDialog1.FileName);
end;
end;
procedure TfrmMain.Loadfromfile1Click(Sender: TObject);
begin
if not (puMemoMenu.PopupComponent
is TMemo)
then
exit;
if OpenDialog1.Execute
then
begin
TMemo(puMemoMenu.PopupComponent).Lines.LoadFromFile(OpenDialog1.FileName);
end;
end;
procedure TfrmMain.UpdateClientList;
var
Count : Integer;
begin
{ Loop through all the clients connected to the system and set their names }
for Count := 0
to lbClients.Items.Count -1
do
if Count < Clients.Count
then
lbClients.Items.Strings[Count] := TSimpleClient(Clients.Items[Count]).
Name;
end;
procedure TfrmMain.tcpServerExecute(AThread: TIdPeerThread);
var
Client : TSimpleClient;
Com,
// System command
Msg :
String;
begin
{ Get the text sent from the client }
Msg := AThread.Connection.ReadLn;
{ Get the clients package info }
Client := Pointer(AThread.Data);
{ Check to see if the clients name has been assigned yet }
if Client.
Name = '
Logging In'
then
begin
{ if not, assign the name and announce the client }
Client.
Name := Msg;
UpdateClientList;
BroadcastMessage('
System', Msg + '
has just logged in.');
AThread.Connection.WriteLn(memEntry.Lines.Text);
end
else
{ If name is set, then send the message }
if Msg[1] = '
#'
then
begin
{ System command }
Com := UpperCase(Trim(Copy(Msg, 2, Pos('
:', Msg) -2)));
Msg := UpperCase(Trim(Copy(Msg, Pos('
:', Msg) +1, Length(Msg))));
if Com = '
CLIENTS'
then
AThread.Connection.WriteLn( '
@' + '
clients:' +
lbClients.Items.CommaText);
end
else
begin
{ Not a system command }
BroadcastMessage(Client.
Name, Msg);
end;
end;
procedure TfrmMain.BroadcastMessage( WhoFrom, TheMessage :
String );
var
Count: Integer;
List : TList;
EMote,
Msg :
String;
begin
Msg := Trim(TheMessage);
if WhoFrom <> '
System'
then
Msg := WhoFrom + '
: ' + Msg;
if EMote <> '
'
then
Msg := Format(Trim(EMote), [WhoFrom]);
List := tcpServer.Threads.LockList;
try
for Count := 0
to List.Count -1
do
try
TIdPeerThread(List.Items[Count]).Connection.WriteLn(Msg);
except
TIdPeerThread(List.Items[Count]).Stop;
end;
finally
tcpServer.Threads.UnlockList;
end;
end;
procedure TfrmMain.btnClientsClick(Sender: TObject);
begin
UpdateClientList;
end;
procedure TfrmMain.btnPMClick(Sender: TObject);
var
Msg :
String;
Client : TSimpleClient;
begin
Msg := InputBox('
Private Message', '
What is the message', '
');
Msg := Trim(Msg);
Msg := '
Chat-Admin:' + '
> ' + Msg;
if (Msg <> '
')
and
(lbClients.ItemIndex <> -1)
then
begin
Client := Clients.Items[lbClients.ItemIndex];
TIdPeerThread(Client.Thread).Connection.WriteLn(Msg);
end;
end;
procedure TfrmMain.btnKillClientClick(Sender: TObject);
var
Msg :
String;
Client : TSimpleClient;
begin
Msg := InputBox('
Disconnect message', '
Enter a reason for the disconnect', '
');
Msg := Trim(Msg);
Msg := '
Chat-Admin:' + '
> ' + Msg;
if (Msg <> '
')
and
(lbClients.ItemIndex <> -1)
then
begin
Client := Clients.Items[lbClients.ItemIndex];
TIdPeerThread(Client.Thread).Connection.WriteLn(Msg);
TIdPeerThread(Client.Thread).Connection.Disconnect;
Clients.Delete(lbClients.ItemIndex);
lbClients.Items.Delete(lbClients.ItemIndex);
end;
end;
procedure TfrmMain.Beenden1Click(Sender: TObject);
begin
Close;
end;
procedure TfrmMain.Timer1Timer(Sender: TObject);
var
Com,
Msg :
String;
begin
if not IdTcpClient1.Connected
then
exit;
Msg := IdTCPClient1.ReadLn('
', 5);
if Msg <> '
'
then
if Msg[1] <> '
@'
then
begin
{ Not a system command }
memLines.Lines.Add(Msg);
end
else
begin
{ System command }
Com := UpperCase(Trim(Copy(Msg, 2, Pos('
:', Msg) -2)));
Msg := UpperCase(Trim(Copy(Msg, Pos('
:', Msg) +1, Length(Msg))));
if Com = '
CLIENTS'
then
lbClients.Items.CommaText := Msg;
end;
end;
procedure TfrmMain.IdTCPClient1Connected(Sender: TObject);
begin
IdTCPClient1.WriteLn(edUserName.Text);
end;
procedure TfrmMain.edmessageKeyPress(Sender: TObject;
var Key: Char);
begin
if key = #13
then
begin
IdTCPClient1.WriteLn(edMessage.Text);
edMessage.Text := '
';
end;
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
if Status = 1
then
begin
idhttp1.Get('
http://www.domain.de/delete.php');
end;
end;
procedure TfrmMain.FormShow(Sender: TObject);
begin
try
ip := idhttp1.get('
http://www.domain.de/ip.txt');
except
//ok
end;
if ip = '
'
then
begin
try
idhttp1.get('
http://www.domain.de/ip.php');
except
//ok
end;
btnServerUp.click;
Status := 1;
end
else
begin
end;
end;
procedure TfrmMain.ToolButton1Click(Sender: TObject);
begin
if (edUserName.Text = '
')
then
begin
ShowMessage('
Bitte Benutzernamen eingeben!');
end
else
begin
IdTCPClient1.Host := '
127.0.0.1';
IdTCPClient1.Port := 23;
IdTCPClient1.Connect;
end;
toolbutton1.Enabled := False;
end;
procedure TfrmMain.ToolButton2Click(Sender: TObject);
begin
idtcpclient1.Disconnect;
toolbutton1.Enabled := True;
end;
end.