chatserverunit.pas

本系统在一些大中型企业(跨多达24个区域)一直都在很好的服务过

unit ChatServerUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  NMUDP, StdCtrls, Buttons, ExtCtrls, Menus;

type
  TMainForm = class(TForm)
    CUDP: TNMUDP;
    Image1: TImage;
    startbt: TSpeedButton;
    Label1: TLabel;
    stopbt: TSpeedButton;
    Label2: TLabel;
    procedure CUDPDataReceived(Sender: TComponent; NumberBytes: Integer;
      FromIP: String);
    procedure FormCreate(Sender: TObject);
    procedure startbtClick(Sender: TObject);
    procedure stopbtClick(Sender: TObject);
  private
    procedure CheckStory(userid,userip:string);
    procedure sendmessage(CtrlCode:integer;UserColor,UserID,ToUserID,Usermsg:string);
    procedure deluseformstory(var UserID:string);
    procedure clearstory;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

type
 userstory=array[1..2,1..30] of string;
var
 usersstory: userstory;
 Runing:boolean;

procedure TMainForm.CheckStory(userid,userip:string);
var
i:integer;
tf:integer;
begin
     TF:=0;

     {mod}
     for i:=1 to 30 do
     begin
       if trim(usersstory[1,i])=trim(userid) then
       begin
       usersstory[2,i]:=trim(userip);
       tf:=1;
       end;
     end;

     if tf<>1 then
     begin

     {add}
       for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])='' then
            begin
             usersstory[1,i]:=trim(userid);
             usersstory[2,i]:=trim(userip);
             exit;
            end;
         end;

     end;


end;




procedure TMainForm.CUDPDataReceived(Sender: TComponent; NumberBytes: Integer;
  FromIP: String);
var
  Recstr: array[0..200] of Char;
  CtrlCode:integer;
  UserID:string;
  ToUserID:string;
  UserIP:string;
  UserMsg:string;
  UserColor:string;
  I:INTEGER;
  p: integer;



begin

   UserID:='';
   UserIP:='';
   UserMsg:='';
   ToUserID:='';
    {读取控制码}
  try
   CUDP.ReadBuffer(Recstr,NumberBytes);
  except
   exit;
  end;

    {识别码读取}

  try
   CtrlCode:=strtoint(Recstr[0]);
  except
   exit;
  end;

if  CtrlCode<> 5  then
begin

    {解析用户名、密码、信息   }
     p:=0;

        for i:=0 to NumberBytes do
         begin
         if recstr[i]='~' then p:=P+1;
         if (p=1) and (recstr[i]<>'~') then  UserID:=trim(UserID+recstr[i]);
         if (p=2)   and (recstr[i]<>'~') then  UserIP:=trim(UserIP+recstr[i]);
         if (p=3)   and (recstr[i]<>'~') then  UserColor:=trim(UserColor+recstr[i]);
         if (p=4)   and (recstr[i]<>'~') then  UserMsg:=trim(UserMsg+recstr[i]);


         end;

       if (trim(UserID)='')  or (trim(UserIp)='') or (trim(UserColor)='')  then exit;


          {保存 用户名、密码、信息 到内存数组}
       CheckStory(UserID,UserIP);

     {据识别码进入相应功能}
       sendmessage(CtrlCode,UserColor,UserID,' ',Usermsg);

end;


if  CtrlCode=5  then  {单独会谈}
begin
{解析用户名、密码、信息   }
     p:=0;

        for i:=0 to NumberBytes do
         begin
         if recstr[i]='~' then p:=P+1;
         if (p=1) and (recstr[i]<>'~') then  UserID:=trim(UserID+recstr[i]);
         if (p=2) and (recstr[i]<>'~') then  UserIP:=trim(UserIP+recstr[i]);
         if (p=3) and (recstr[i]<>'~') then  UserColor:=trim(UserColor+recstr[i]);
         if (p=4) and (recstr[i]<>'~') then  ToUserID:=trim(ToUserID+recstr[i]);
         if (p=5) and (recstr[i]<>'~') then  UserMsg:=trim(UserMsg+recstr[i]);

         end;

       if (trim(UserID)='')  or (trim(UserIp)='') or (trim(UserColor)='') or (trim(ToUserID)='') then exit;
          {保存 用户名、密码、信息 到内存数组}
       CheckStory(UserID,UserIP);

     {据识别码进入相应功能}
       sendmessage(CtrlCode,UserColor,UserID,touserid,Usermsg);

end;





end;


 function  Liststory :string;
 var
 i:integer;
 begin
  result:='';
  for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])<>'' then
            begin
            if  result='' then  result:=usersstory[1,i]+'@' else result:=result+usersstory[1,i]+'@';
            end;
         end;


 end;



procedure TMainForm.sendmessage(CtrlCode:integer;UserColor,UserID,touserid,Usermsg:string);
var
  sendstr: array[0..200] of Char;
  i:integer;
  sendmsg:string;
  usergroup:string;
 begin



 case  CtrlCode of

    0: begin         {初始登录}
     if not Runing then exit;
     usergroup:=Liststory;
     sendmsg:='0'+'~'+UserColor+'~'+usergroup+'~'+Usermsg;
     strPCopy(sendstr,sendmsg);

            for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])<>'' then
            begin
             CUDP.RemoteHost:=trim(usersstory[2,i]);
             CUDP.SendBuffer(sendstr,length(sendmsg));
            end;
         end;


       end;
{==============================================================================}

    1: begin

    if not Runing then exit;
        {正常会话}
     sendmsg:='1'+'~'+UserColor+'~'+UserID+'~'+Usermsg;
     strPCopy(sendstr,sendmsg);

            for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])<>'' then
            begin
             CUDP.RemoteHost:=trim(usersstory[2,i]);
             CUDP.SendBuffer(sendstr,length(sendmsg));
            end;
         end;



{==============================================================================}
 end;

    2: begin
              if not Runing then exit;
              deluseformstory(UserID);
              sendmsg:='2'+'~'+UserColor+'~'+UserID+'~'+Usermsg;
              strPCopy(sendstr,sendmsg);

               for i:=1 to 30 do
                    begin
                       if trim(usersstory[1,i])<>'' then
                         begin
                           CUDP.RemoteHost:=trim(usersstory[2,i]);
                           CUDP.SendBuffer(sendstr,length(sendmsg));
                         end;
                    end;

       end;



    3: begin       {关闭}
{===============================================================================}

        sendmsg:='3'+'~'+UserColor+'~'+'NULL'+'~'+'网络会议服务器已经被系统管理员关闭!';
        strPCopy(sendstr,sendmsg);

            for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])<>'' then
            begin
             CUDP.RemoteHost:=trim(usersstory[2,i]);
             CUDP.SendBuffer(sendstr,length(sendmsg));
            end;
         end;
         Runing:=false;
         stopbt.Enabled:=false;
         startbt.Enabled:=true;
         clearstory;
       end;
{================================================================================}

    4: begin       {启动}
{===============================================================================}

        sendmsg:='4'+'~'+UserColor+'~'+'NULL'+'~'+'启动...';
        strPCopy(sendstr,sendmsg);

            for i:=1 to 30 do
         begin
           if trim(usersstory[1,i])<>'' then
            begin
             CUDP.RemoteHost:=trim(usersstory[2,i]);
             CUDP.SendBuffer(sendstr,length(sendmsg));
            end;
         end;
         Runing:=true;
         stopbt.Enabled:=true;
         startbt.Enabled:=false;
        clearstory;
       end;
{================================================================================}

    5: begin    {单独会谈}

     if not Runing then exit;



     sendmsg:='5'+'~'+userid+'~'+UserColor+'~'+touserid+'~'+Usermsg;
     strPCopy(sendstr,sendmsg);

            for i:=1 to 30 do
         begin
           if (trim(usersstory[1,i])=userid) or  (trim(usersstory[1,i])=touserid) then
            begin
             CUDP.RemoteHost:=trim(usersstory[2,i]);
             CUDP.SendBuffer(sendstr,length(sendmsg));
            end;
         end;




    
       end;


    end;{end case}

 end;

procedure TMainForm.deluseformstory(var UserID:string);
var
i:integer;
begin
   {del user who have quit}
     for i:=1 to 30 do
     begin
       if trim(usersstory[1,i])=trim(userid) then
       begin
       usersstory[2,i]:='';
       usersstory[1,i]:='';

       end;
     end;
end;

procedure TMainForm.clearstory;
var
i:integer;
begin
 {clear All user }
     for i:=1 to 30 do
     begin

       usersstory[2,i]:='';
       usersstory[1,i]:='';

     end;

end;


procedure TMainForm.FormCreate(Sender: TObject);
begin
Runing:=true;
end;

procedure TMainForm.startbtClick(Sender: TObject);
begin
Runing:=true;
stopbt.Enabled:=true;
startbt.Enabled:=false;
end;

procedure TMainForm.stopbtClick(Sender: TObject);
begin
Runing:=false;
stopbt.Enabled:=false;
startbt.Enabled:=true;
end;

end.