serverunit.pas

一个支持多用在线聊天的工具

          GetSocketByUser(UserToUsers[N].Users[j],PrivateSocket);
          MsgToSend:='<'+UserNickName+'>'+additional;
          PrivateSocket.SendText(MsgToSend);
       end;
     end;
   SN_UPDATE_UToUs:
     begin
        UpdateUToUs(additional,UserNickName);//更新UserToUsers
     end;
   end;//case
end;
procedure TChatServer.ADDUToUs(UserNickName:string;RemoteAddress:string);
var
   TempUToUs:array of UToUs;
   i:integer;
begin
   //添加私聊用户列表
   if ConnectionsListView.Items.Count>1 then
   begin
        //保存原来的
        SetLength(TempUToUs,High(UserToUsers)+1);
        for i:=0 to High(UserToUsers) do
           TempUToUs[i]:=UserToUsers[i];
        //增加
        SetLength(UserToUsers,ConnectionsListView.Items.Count);
        //恢复原来的
        for i:=0 to High(TempUToUs) do
           UserToUsers[i]:=TempUToUs[i];
        //加入新来的
        UserToUsers[High(UserToUsers)].User:=UserNickName;
        UserToUsers[High(UserToUsers)].RemoteAddress:=RemoteAddress;
        UserToUsers[High(UserToUsers)].BroadFlag:=True;
   end else
   begin    //第一个人近来
        SetLength(UserToUsers,ConnectionsListView.Items.Count);
        UserToUsers[0].User:=UserNickName;
        UserToUsers[0].RemoteAddress:=RemoteAddress;
        UserToUsers[0].BroadFlag:=True;
   end;
end;
procedure TChatServer.DELUToUs(UserNickName:string);
var
  i,n:integer;
  TempUToUs:array of UToUs;
begin
   //添加私聊用户列表
   if ConnectionsListView.Items.Count>0 then
   begin
        //保存原来的
        SetLength(TempUToUs,High(UserToUsers)+1);
        for i:=0 to High(UserToUsers) do
           TempUToUs[i]:=UserToUsers[i];
        //增加
        SetLength(UserToUsers,ConnectionsListView.Items.Count);
        //恢复没被删除的
        n:=0;
        for i:=0 to High(TempUToUs) do
          if TempUToUs[i].User<>UserNickName then
          begin
               UserToUsers[n]:=TempUToUs[i];
               n:=n+1;
          end;
   end else
   begin    //没人了
        SetLength(UserToUsers,0);
   end;

end;
procedure TChatServer.UpdateUToUs(str:string;UserNickName:string);
var
   i:Integer;
   Count,N:Integer;
begin
   //Rain_Private:test2,test3,
   Delete(str,1,Length('Rain_Private:'));
   N:=GetUserID(UserNickName);
   //Count the Users
   Count:=0;
   for i:=1 to Length(Str) do
   begin
      if Str[i] = ',' then
        Count:=Count+1;
   end;
   if Count>0 then     //有私聊用户
   begin
      UserToUsers[N].BroadFlag:=False;
      SetLength(UserToUsers[N].Users,Count);
      for i:=0 to Count-1 do
      begin
         UserToUsers[N].Users[i]:=Copy(str,1,Pos(',',str)-1);
         Delete(str,1,Pos(',',str));
      end;
   end else
      UserToUsers[N].BroadFlag:=True;
end;
procedure TChatServer.ChatServerSocketClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  SendNotification(SN_lOGOFF,'',Socket);
  ReMoveConnectionFromListview(Socket);
  UpdateStatusBar(True);
  UpdateTrayTip;
end;

procedure TChatServer.ChatServerSocketClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  AddLogEntry(LET_ERROR,'Socket Error'+IntToStr(ErrorCode));
  SendNotification(SN_lOGOFF,'',Socket);
  ReMoveConnectionFromListview(Socket);
  ErrorCode:=0;
  UpdateStatusBar(True);
  UpdateTrayTip;
end;

procedure TChatServer.BroadcastMessage(Message:AnsiString;ExcludeSocket: TCustomWinSocket);
var
   i:integer;
begin
   for i:=0 to ChatServerSocket.Socket.ActiveConnections-1 do
   begin
     if ChatServerSocket.Socket.Connections[i]<>ExcludeSocket then
        ChatServerSocket.Socket.Connections[i].SendText(Message);
   end;
end;

procedure TChatServer.GetOnLineUserList(var OnLineUserList:string);
var
   i:integer;
begin
   for i:=0 to ConnectionsListview.Items.Count-1 do
   begin
      OnLineUserList:=OnLineUserList+ConnectionsListview.Items.Item[i].Caption+',';
   end;
end;

procedure TChatServer.ChatServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
   UserNickName,loginresponse,recvtxt:AnsiString;
   index:integer;
   OnLineUserList:string;
   N:Integer;
begin
   if Socket.Data=nil then    //刚连进来
   begin
      UserNickName:=Socket.ReceiveText;
      index:=Pos('\n',UserNickName);
      if index>1 then
         SetLength(UserNickName,index-1)
      else
         UserNickName:='UnKnown or invalid'+IntToStr(Socket.SocketHandle);
      SetUserBySocket(Socket,UserNickName);//重设用户名
      Socket.Data:=Pointer(1);
      loginresponse:=UserNickName+', 欢迎你来到风雨同舟聊天室！！！';
//    send to self
      GetOnLineUserList(OnLineUserList);
      //Rain_Update:test1,test2,test3,\ntest1....
      Socket.SendText('Rain_Update:'+OnLineUserList+'\n'+loginresponse);
      SendNotification(SN_LOGON,'',Socket);
   end
   else
   begin
      recvtxt:=Socket.ReceiveText;
      //消息头是Rain_MSG:
      //更新UserToUsers的头是Rain_Private:
      if (Pos('Rain_Private:',recvtxt) <> 0) and (Pos('Rain_MSG:',recvtxt)=0) then
          SendNotification(SN_UPDATE_UToUs,recvtxt,Socket)
      else
      begin
        GetUserBySocket(Socket,UserNickName);
        N:=GetUserID(UserNickName);
        if  UserToUsers[N].BroadFlag then
           SendNotification(SN_PUBLIC_MSG,recvtxt,Socket)
        else
           SendNotification(SN_PRIVATE_MSG,recvtxt,Socket);
      end;
   end;
end;
function  TChatServer.GetUserID(UserName:string):Integer;
var
   i:Integer;
begin
   for i:=0 to High(UserToUsers) do
   begin
      if UserToUsers[i].User = UserName then
      begin
         Result:=i;
         Exit;
      end;
   end;
   Result:=0;
end;
procedure TChatServer.MaxTray(Sender: TObject);
begin
  ShowWindow(Application.Handle,SW_NORMAL);
  Shell_NotifyIcon(NIM_DELETE,@Pnid);
end;                                                       //
                                                            //
procedure TChatServer.MiniTray(Sender: TObject);
begin                                                       //

  Shell_NotifyIcon(NIM_ADD,@Pnid);
  ShowWindow(Application.Handle,SW_HIDE);
  UpdateTrayTip;
end;
//////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
procedure TChatServer.WMmyicon(var MSG:Tmessage);           //
var                                                        //
  Pos:TPoint;                                              //
begin                                                      //
   if MSG.Msg   = WM_MYICON  then
    begin
      GetCursorPos(Pos);
       case MSG.LParam of                                       //
           WM_RBUTTONDOWN:
            begin
              SetForegroundWindow(Application.Handle);
              PopupMenu1.PopUp(Pos.x,Pos.y);
              PostMessage(Pnid.Wnd,WM_USER,0,0);
            end;
           WM_LBUTTONDBLCLK:
           begin
             SetForegroundWindow(Application.Handle);
             RestorePopItemClick(Application);
           end;
       end;
    end  
    else
      DefWindowProc(Application.Handle,Msg.Msg,Msg.WParam,Msg.lParam); //
end;                                                       //
/////////////////////////////////////////////////////////////
procedure TChatServer.RestorePopItemClick(Sender: TObject);
begin
   Application.Restore;
end;

procedure TChatServer.StartStopServerPopItemClick(Sender: TObject);
begin
   StartStopServerMenuItemClick(application);
end;

procedure TChatServer.X1Click(Sender: TObject);
begin
  Close;
end;

procedure TChatServer.ExitPopItemClick(Sender: TObject);
begin
 Shell_NotifyIcon(NIM_DELETE,@Pnid);
 Close;
end;
procedure TChatServer.UpdateTrayTip;
var
   TempStr:string;
begin
   TempStr:=ChatServerStatusbar.Panels[0].Text;
   if ChatServerSocket.Socket.ActiveConnections>0 then
   begin

      StrCopy(Pnid.szTip,Pchar(TempStr));
   end
   else
      Pnid.szTip:='风雨同舟聊天室';
   Shell_NotifyIcon(NIM_MODIFY,@Pnid);
end;
procedure TChatServer.AutoRunMenuItemClick(Sender: TObject);
var
   RegF:TRegistry;
begin
   RegF:=TRegistry.Create;
   RegF.RootKey:=HKEY_LOCAL_MACHINE;
   AutoRunMenuItem.Checked:=not AutoRunMenuItem.Checked;
   if AutoRunMenuItem.Checked then //自动运行
   begin
      try
        RegF.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run',True);
        RegF.WriteString('MultiChat',Application.ExeName);
      finally
        RegF.CloseKey;
        RegF.Free;
      end;
   end
   else                      //删除自动运行
   begin
      try
        RegF.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run',True);
        RegF.DeleteValue('MultiChat');
      finally
        RegF.CloseKey;
        RegF.Free;
      end;
   end;
end;

procedure TChatServer.SpeedButton1Click(Sender: TObject);
begin
    StartStopServerMenuItemClick(application);
end;

procedure TChatServer.FormPaint(Sender: TObject);
begin
 if AutoRunMenuItem.Checked  and CanPaint then
 begin
  Shell_NotifyIcon(NIM_ADD,@Pnid);
  ShowWindow(Application.Handle,SW_MINIMIZE);
  ShowWindow(Application.Handle,SW_HIDE);
  UpdateTrayTip;
 end;
 CanPaint:=False;
end;

procedure TChatServer.AboutMenuItemClick(Sender: TObject);
begin
   ShowMessage('     欢迎使用风雨同舟聊天室'+#13#10+'          RainChatServer Ver1.0'+#13#10+' http://rainsoft.home.chinaren.com');
end;

procedure TChatServer.A1Click(Sender: TObject);
begin
  AboutMenuItemClick(application);
end;

procedure TChatServer.NMUDP1DataReceived(Sender: TComponent;
  NumberBytes: Integer; FromIP: String; Port: Integer);
var
   Buff:array[0..800] of Char;
   Len:Integer;
   i,N:Integer;
begin
   //接收
   NMUDP1.ReadBuffer(Buff,Len);
   //转发
   //找到指定用户
   N:=0;
   for i:=0 to High(UserToUsers) do
      if UserToUsers[i].RemoteAddress = FromIP then
      begin
         N:=i;
         break;
      end;
   if UserToUsers[N].BroadFlag then //广播
   begin
      for i:=0 to High(UserToUsers) do
         if UserToUsers[i].RemoteAddress<>FromIP then
         begin
           NMUDP1.RemoteHost:=UserToUsers[i].RemoteAddress;
           NMUDP1.RemotePort:=Port;
           NMUDP1.SendBuffer(Buff,Len);
         end;
   end else
   //指定用户的私聊用户列表
   for i:=0 to High(UserToUsers[N].Users) do
   begin
      NMUDP1.RemoteHost:=GetRemoteAddressByUser(UserToUsers[N].Users[i]);
      NMUDP1.RemotePort:=Port;
      NMUDP1.SendBuffer(Buff,Len);
   end;
end;
function TChatServer.GetRemoteAddressByUser(UserName:string):string;
var
   i:Integer;
begin
   for i:=0 to High(UserToUsers) do
      if UserToUsers[i].User = UserName then
      begin
          Result:=UserToUsers[i].RemoteAddress;
          Exit;
      end;
   Result:='';
end;
end.