serverunit.pas

IPXControl: 本软件是一个免费控件

//===================================================================//
//多用户语音聊天服务器                                               //
//接收格式：含有Rain_Private:头的是该用户的私聊列表。                //
//          含有Rain_MSG:头的是需转发的消息。                        //
//发送格式：更新在线用户列表：Rain_Update:+OnLinUserList             //
//          转发消息：去掉Rain_MSG:头后发送                          //
//===================================================================//
unit ServerUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ExtCtrls, ComCtrls, Buttons, ScktComp,ShellApi,registry, NMUDP;
type UToUs = record
     User:string;
     Users:array of string;
     RemoteAddress:string;
     BroadFlag:Boolean;
end;
type ServerStatus=(SS_NOT_RUNNING,SS_RUNNING);
type LogEntryType=(LET_WARNING,LET_ERROR,LET_SIGNON,LET_SIGNOFF);
type ServerNotification=(SN_LOGON,SN_LOGOFF,SN_PUBLIC_MSG,SN_PRIVATE_MSG,SN_UPDATE_UToUs);
const CHAT_SERVER_PORT=6778;
      WM_MYICON=WM_USER+1001;
type
  TChatServer = class(TForm)
    ChatServerStatusBar: TStatusBar;
    ConnectionsListView: TListView;
    LogEntryListView: TListView;
    Bevel1: TBevel;
    MainMenu1: TMainMenu;
    StartStopServerMenuItem: TMenuItem;
    X1: TMenuItem;
    H1: TMenuItem;
    AboutMenuItem: TMenuItem;
    Panel1: TPanel;
    Splitter1: TSplitter;
    SpeedButton1: TSpeedButton;
    ChatServerSocket: TServerSocket;
    PopupMenu1: TPopupMenu;
    RestorePopItem: TMenuItem;
    StartStopServerPopItem: TMenuItem;
    N2: TMenuItem;
    ExitPopItem: TMenuItem;
    AutoRunMenuItem: TMenuItem;
    F1: TMenuItem;
    N3: TMenuItem;
    A1: TMenuItem;
    NMUDP1: TNMUDP;
    procedure FormCreate(Sender: TObject);
    procedure StartStopServerMenuItemClick(Sender: TObject);
    procedure ChatServerSocketClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ChatServerSocketClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ChatServerSocketClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    procedure ChatServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure RestorePopItemClick(Sender: TObject);
    procedure StartStopServerPopItemClick(Sender: TObject);
    procedure X1Click(Sender: TObject);
    procedure ExitPopItemClick(Sender: TObject);
    procedure AutoRunMenuItemClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure AboutMenuItemClick(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure NMUDP1DataReceived(Sender: TComponent; NumberBytes: Integer;
      FromIP: String; Port: Integer);
  private
      CurrentServerStatus:ServerStatus;
      procedure UpdateTrayTip;
      procedure MaxTray(Sender: TObject);
      procedure MiniTray(Sender: TObject);
      procedure WMmyicon(var MSG:Tmessage);

      procedure IdleEventResponse(Sender:TObject;var Done:Boolean);
      procedure SetServerStatus(_serverstatus:ServerStatus);
      procedure AddConnectionToListView(ClientSocket: TCustomWinSocket);
      procedure RemoveConnectionFromListView(Socket: TCustomWinSocket);
      procedure UpdateStatusBar(DecUse:Boolean);
      procedure AddLogEntry(let:LogEntryType;EntryText:AnsiString);
      procedure SetUserBySocket(Socket: TCustomWinSocket;const UserNickName:AnsiString);
      procedure GetUserBySocket(Socket: TCustomWinSocket;var UserNickName:AnsiString);
      procedure GetSocketByUser(PrivateName:string;var PrivateSocket:TCustomWinsocket);
      function  ListItemBySocket(Socket: TCustomWinSocket):TListItem;
      procedure BroadcastMessage(Message:AnsiString;ExcludeSocket: TCustomWinSocket);
      procedure GetOnLineUserList(var OnLineUserList:string);
      procedure SendNotification(sn:ServerNotification;additional:AnsiString;ExcludeSocket: TCustomWinSocket);
      procedure UpdateUToUs(str:string;usernickName:string);
      procedure ADDUToUs(UserNickName:string;RemoteAddress:string);
      procedure DELUToUs(UserNickName:string);
      function GetUserID(UserName:string):Integer;
      function GetRemoteAddressByUser(UserName:string):string;
  public
    { Public declarations }
  end;
var
  ChatServer: TChatServer;
  Pnid:NOTIFYICONDATA;
  CanPaint:Boolean;
  UserToUsers:array of UToUs;
implementation

{$R *.DFM}

procedure TChatServer.FormCreate(Sender: TObject);
var
  RegF:TRegistry;
begin
  Application.OnIdle:=IdleEventResponse;
  Application.OnMinimize:=MiniTray;
  Application.OnRestore:=MaxTray;
//  Application.OnMessage:=WMmyIcon;
  CurrentServerStatus:=SS_NOT_RUNNING;
  ChatServerSocket.port:=CHAT_SERVER_PORT;
  CanPaint:=True;
  Pnid.cbSize:=sizeof(NOTIFYICONDATA);
  Pnid.Wnd:=AllocateHWnd(WmMyIcon);                             //
  Pnid.uID:=1;
  Pnid.uFlags:=NIF_TIP or NIF_ICON or NIF_MESSAGE;
  Pnid.uCallbackMessage:=WM_MYICON;                          //
  Pnid.hIcon:=Application.Icon.Handle;

  RegF:=TRegistry.Create;
  RegF.RootKey:=HKEY_LOCAL_MACHINE;
  AutoRunMenuItem.Checked:=False;
   try
     RegF.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run',True);
     if  RegF.ValueExists('MultiChat') then
        if (RegF.ReadString('MultiChat')=Application.ExeName) then
            AutoRunMenuItem.Checked:=True;

  finally
    RegF.CloseKey;
    RegF.Free;
  end;
  if AutoRunMenuItem.Checked then
  begin
      StartStopServerMenuItemClick(application);
  end;
end;

procedure TChatServer.IdleEventResponse(Sender:TObject;var Done:Boolean);
begin
  if (CurrentServerStatus<>SS_RUNNING) then
  begin
    StartStopServerMenuItem.Caption:='启动聊天服务器(&S)';
    StartStopServerPopItem.Caption:='启动聊天服务器(&S)';
    SpeedButton1.Hint:='启动聊天服务器';
  end
  else
  begin
    StartStopServerMenuItem.Caption:='关闭聊天服务器(&C)';
    StartStopServerPopItem.Caption:='关闭聊天服务器(&C)';
    SpeedButton1.Hint:='关闭聊天服务器';
  end;
end;

procedure TChatServer.AddLogEntry(let:LogEntryType;EntryText:AnsiString);
var
   Item:TListItem;
   entrytype:AnsiString;
   procedure EntryTypeToText(let:LogEntryType; var text :AnsiString);
   begin
      case let of
      LET_WARNING:
           begin
              text:='敬告';
           end;
      LET_ERROR:
           begin
              text:='错误';
           end;
      LET_SIGNON:
           begin
              text:='用户进入';
           end;
      LET_SIGNOFF:
           begin
              text:='用户离开';
           end;
      else
           begin
              text:='不知道';
           end;
      end;//case
   end;//function

begin
   item:=LogEntryListview.Items.Add;
   EntryTypeToText(let,entrytype);
   item.Caption:=entrytype;
   item.SubItems.Add(EntryText);
   Item.SubItems.Add(DateTimeToStr(Now));
end;

procedure TChatServer.SetServerStatus(_serverstatus:ServerStatus);
begin
  CurrentServerStatus:=_serverstatus;
end;

procedure TChatServer.StartStopServerMenuItemClick(Sender: TObject);
begin
  case CurrentServerStatus of
  SS_NOT_RUNNING:
    begin
      ChatServerSocket.Open;
      SetServerStatus(SS_RUNNING);
      AddLogEntry(LET_WARNING,'服务器已起动...');
    end;
  SS_RUNNING:
    begin
      ChatServerSocket.Close;
      SetServerStatus(SS_NOT_RUNNING);
      AddLogEntry(LET_WARNING,'服务器已停止...');
    end;
  end;//case
  UpdateStatusBar(False);
  UpdateTrayTip;
end;

procedure TChatServer.AddConnectionToListView(ClientSocket: TCustomWinSocket);
var
   UserNickName:AnsiString;
   TempItem:TListItem;
begin
   UserNickName:='未知名';
   TempItem:=ConnectionsListView.Items.Add;
   TempItem.Caption:=UserNickName;
   TempItem.SubItems.Add(ClientSocket.RemoteHost);
   TempItem.SubItems.Add(DateTimeToStr(Now));
   TempItem.Data:=ClientSocket;//保存
end;

function TChatServer.ListItemBySocket(Socket: TCustomWinSocket):TListItem;
var
   i:integer;
begin
   for i:=0 to ConnectionsListView.Items.Count-1 do  /////////////////////////
   begin
      if TCustomWinSocket(ConnectionsListView.Items.Item[i].Data)=Socket then
      begin
         Result:=ConnectionsListView.Items.Item[i];
         Exit;
      end;
   end;
   Result:=nil;
end;

procedure TChatServer.RemoveConnectionFromListView(Socket: TCustomWinSocket);
var
   Item:TListItem;
   UserNickName:string;
begin
   Item:=ListItemBySocket(Socket);
   if Item<>nil then
   begin
       UserNickName:=ConnectionsListview.Items[item.index].Caption;
       ConnectionsListview.Items.Delete(item.index);
       DELUToUs(UserNickName);
   end;
end;

procedure TChatServer.SetUserBySocket(Socket: TCustomWinSocket;const UserNickName:AnsiString);
var
   Item:TListItem;
begin
   Item:=ListItemBySocket(Socket);
   if Item<>nil then
       Item.Caption:=UserNickName;
   ADDUToUs(UserNickName,Socket.RemoteAddress);
end;

procedure TChatServer.GetSocketByUser(PrivateName:string;var PrivateSocket:TCustomWinsocket);
var
   i:Integer;
begin
   for i:=0 to ConnectionsListView.Items.Count-1 do  /////////////////////////
   begin
      if ConnectionsListView.Items.Item[i].Caption = PrivateName then
      begin
         PrivateSocket:=TCustomWinSocket(ConnectionsListView.Items.Item[i].Data);
         Exit;
      end;
   end;
   PrivateSocket:=nil;
end;
procedure TChatServer.GetUserBySocket(Socket: TCustomWinSocket;var UserNickName:AnsiString);
var
   Item:TListItem;
begin
   Item:=ListItemBySocket(Socket);
   if Item<>nil then
     UserNickName:=Item.Caption
   else
     UserNickName:='未知名';
end;

procedure TChatServer.UpdateStatusBar(DecUse:Boolean);
begin
  case CurrentServerStatus of
  SS_NOT_RUNNING:
      begin
         ChatServerStatusBar.Panels[0].Text:='在菜单中选启动服务器...';
      end;
  SS_RUNNING:
      begin
        if DecUse then
          ChatServerStatusBar.Panels[0].Text:='在线用户有'+
                           IntToStr(ChatServerSocket.Socket.ActiveConnections-1)+'位'
        else
          ChatServerStatusBar.Panels[0].Text:='在线用户有'+
                           IntToStr(ChatServerSocket.Socket.ActiveConnections)+'位';
      end;
  end;//case
end;

procedure TChatServer.ChatServerSocketClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
     Socket.Data:=nil;
     AddConnectionToListView(Socket);
     UpdateStatusBar(False);
     UpdateTrayTip;
end;

procedure TChatServer.SendNOtification(sn:ServerNotification;additional:AnsiString;ExcludeSocket: TCustomWinSocket);
var
   UserNickName:AnsiString;
   MsgToSend:AnsiString;
   OnLineUserList:string;
   PrivateSocket:TCustomWinSocket;
   j,N:integer;
begin
   GetUserBySocket(ExcludeSocket,UserNickName);  //获得用户名
   case sn of
   SN_LOGON:
     begin
       AddLogEntry(LET_SIGNON,UserNickName);
       GetOnLineUserList(OnLineUserList);
       //Message: Rain_Update:Test1,Test2,\ntest1...'
       BroadcastMessage('Rain_Update:'+OnLineUserList+'\n'
                         +UserNickName+' 进入聊天室！！！',ExcludeSocket);
     end;
   SN_LOGOFF:
     begin
       AddLogEntry(LET_SIGNOFF,UserNickName);
       GetOnLineUserList(OnLineUserList);
       //Delete UserNickName
       //test1,test2,test3,
       //Rain_Update:test1,test2,\ntest1...
       Delete(OnLineUserList,Pos(UserNickName,OnLineUserList),Length(UserNickName)+1);
       BroadcastMessage('Rain_Update:'+OnLineUserList+'\n'
                         +UserNickName+' 离开了！！！',ExcludeSocket);

     end;
   SN_PUBLIC_MSG:
     begin
       //去掉头Rain_MSG:
       Delete(additional,1,Length('Rain_MSG:'));
       MsgToSend:='<'+UserNickName+'>'+additional;
       BroadcastMessage(MsgToSend,ExcludeSocket);
     end;
   SN_PRIVATE_MSG:    //悄悄话
     begin
       //去掉头Rain_MSG:
       Delete(additional,1,Length('Rain_MSG:'));
       N:=GetUserID(UserNickName);
       for j:=0 to High(UserToUsers[N].Users) do
       begin