我仿idtcpdemo做的一个idtcpserver的server端,由于线程很对象以前几乎没有接触过这个概念,所以毛病很多。
程序的主要毛病是,启动之后没问题,然后serveron,然后client连接进来。然后client断开。然后serveroff,然后关闭server程序,但是关闭server程序的时候会出现runtime error,xp系统下,delphi7,然后系统不断的出现那个winxp特有的错误提示信息,问是否要发送到microsoft。server只要不关闭,on 和off都没有问题,on之后client连接断开也都没有问题。
小子是新人,分不太多,达人帮忙看看毛病出在什么地方,谢谢了。主窗体代码如下:
unit frmServerMain;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent,
  IdTCPServer, StdCtrls,BaseDeclaration;type
  TfrmMain = class(TForm)
    cmdServerOn: TButton;
    server: TIdTCPServer;
    IdThreadMgrDefault1: TIdThreadMgrDefault;
    cmdServerOff: TButton;
    Log: TMemo;
    procedure cmdServerOnClick(Sender: TObject);
    procedure serverConnect(AThread: TIdPeerThread);
    procedure serverExecute(AThread: TIdPeerThread);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure cmdServerOffClick(Sender: TObject);
    procedure serverDisconnect(AThread: TIdPeerThread);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
Pclient=^TClient;
TClient=Record
NickName:string[20];
strIP :string[15];
Thread:Pointer;
end;var
  frmMain: TfrmMain;
  Clients:TThreadlist;
implementation{$R *.dfm}procedure TfrmMain.serverConnect(AThread: TIdPeerThread);
var
  NewClient:PClient;
begin
  GetMem(NewClient,sizeof(newclient));
  NewClient.strIP := athread.Connection.Socket.Binding.PeerIP;
  NewClient.Thread:=AThread;
  
  AThread.Data :=TObject(NewClient);
  try
    Clients.LockList.Add(NewClient);
  finally
    Clients.UnlockList;
  end;
  log.Lines.Add('Connected');end;
procedure TfrmMain.serverExecute(AThread: TIdPeerThread);
Var
typDataBlock,typNewDataBLock:TDataBlock;
PCurrentClient,PTargetClient:PClient;
PTargetClientThread:TIdPeerThread;
intCounter:integer;
begin
if not AThread.Terminated and AThread.Connection.Connected then
  begin
    AThread.Connection.ReadBuffer (typDataBlock,SizeOf(typDataBlock));
    PCurrentClient:=PClient(AThread.Data );
    if typDataBlock.strCMD ='Login' then
    begin
      PCurrentclient.strIP :=athread.Connection.Socket.Binding.PeerIP ;
      PCurrentclient.NickName :=typDatablock.objMSGSender.strNickName;
      Log.Lines.Add(timetostr(now)+'User'+ PCurrentclient.NickName +'Login');
      with Clients.LockList do
        try
          for intCounter := 0 to Count-2 do  
        begin
            PTargetClient := Items[intCounter];
            typNewDataBlock.strCMD :='Client';
            typNewDataBlock.objMSGSender.strIp :=PTargetClient.strIP ;
            typNewDataBlock.objMSGSender.strNickName :=PTargetClient.NickName ;
            AThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
          end;
        finally
          Clients.UnlockList;
      end;
      typNewDataBlock.strCMD :='Login';
      typNewDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
      typNewDataBlock.objMSGSender.strIp :=PCurrentClient.strIP ;
      with Clients.LockList do
        try
          for intCounter := 0 to Count-2 do
        begin
            PTargetClient := Items[intCounter];
            PTargetClientThread := PTargetClient.Thread;
            PTargetClientThread.Connection.WriteBuffer(typNewDataBlock, SizeOf(typNewDataBlock), True);
          end;
        finally
          Clients.UnlockList;
      end;
    end
    else
    begin
    end;
  end;
end;procedure TfrmMain.serverDisconnect(AThread: TIdPeerThread);
var
  PCurrentClient,PTargetClient:PClient;
  typDataBlock:TDataBlock;
  PTargetClientThread:TIdPeerThread;
  intCounter:integer;
begin
  PCurrentClient:=PClient(AThread.Data );
  typDataBlock.strCMD := 'Logoff';
  typDataBlock.objMSGSender.strNickName :=PCurrentClient.NickName ;
  log.Lines.Add('Disconnected');
  try
    Clients.LockList.Remove(PCurrentClient);
  finally
    Clients.UnlockList;
  end;
  FreeMem(PCurrentClient);
  AThread.Data := nil;  with Clients.LockList do
    begin
    if count > 0 then
    try
      for intCounter := 0 to Count-1 do  
      begin
        PTargetClient := Items[intCounter];          
        PTargetClientThread := PTargetClient.Thread;     
        PTargetClientThread.Connection.WriteBuffer(typDataBlock, SizeOf(typDataBlock), True);        end;
    finally
      Clients.UnlockList;
    end;
  end;
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if server.Active then
cmdserveroff.Click ;
except
on E:Exception do ;
end;
Clients.Free ;
end;procedure TfrmMain.FormCreate(Sender: TObject);
begin
cmdserveroff.Enabled :=false;
Clients := TThreadList.Create;
end;procedure TfrmMain.cmdServerOnClick(Sender: TObject);beginserver.Active :=True;
cmdServerON.Enabled :=False;
cmdServerOff.Enabled := true;
end;procedure TfrmMain.cmdServerOffClick(Sender: TObject);
var
  PTargetClient:PClient;
  PTargetClientThread:TIdPeerThread;
  intCounter:integer;
begin
  cmdServerOn.Enabled :=True;
  cmdserveroff.Enabled := false;
  with Clients.LockList do
    begin
    if count > 0 then    try
      for intCounter := 0 to Count-1 do
      begin
        PTargetClient := Items[0];
        PTargetClientThread := PTargetClient.Thread;        PTargetClientThread.Connection.Disconnect;      end;
    finally
      Clients.UnlockList;
    end;
  end;  try
  server.Active :=false;
  except
  on E:Exception do ;
  end;end;end.另外还有一个模块:
unit BaseDeclaration;interfaceType
 TUser=Record
  strIp:string[15];
  strNickName:string[20];
  end;TDataBlock = Record
 strCMD:string[20];
 objMSGSender:TUser;
 strMSGReceiver:string[20];
 strData:string[100];
 end;
implementationend.