idtcpclient1 Fehler in Auswertung

[Muetzi]

Hallo,


ich habe ein Problem bei folgendem Code. Wenn ich Nachrichten an den Server sende verarbeitet er sie richtig weiter. nur wenn ich ein Command sende trennt der client die Verbindung und alles bricht ab...

hier der Code:

Delphi-Quellcode:

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;

Der Komplette Code sieht so aus:

Delphi-Quellcode:

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.

Gruß

Muetzi

[Muetzi]

niemand ne ahnung?