http://blog.sina.com.cn/myblacksky[订阅]
字体大小：大中小 正文
Delphi 聊天室（带QQ表情）--Client端(1)(2008-08-01 11:21:59)
标签：it  分类：Delphi相关

//////////////////////////Client////////////////////////////

 

 

unit UFrmChatRoom;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,zlib,
  Dialogs, ExtCtrls, StdCtrls, RxRichEd, ScktComp,gifimage,RxGIF,ImageOleLib_TLB,ShellAPI,
  RzButton, RzRadChk, DB, DBClient, Buttons;
const
    WM_BARICON=WM_USER+200;
    sc_DragMove:longint=$F012;
    WM_ACTIVE_CLIENT = WM_USER + 1000;
    //MAX_FILE_SIZE=2000;  //读取FACE.DLL文件大小()
const
   IID_IOleObject: TGUID = (
       D1: $00000112; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00,
       $46));
   EM_GETOLEINTERFACE = WM_USER + 60;
type
  TFrmChatRoom = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    PnlClient: TPanel;
    Panel13: TPanel;
    Panel16: TPanel;
    Panel7: TPanel;
    Label3: TLabel;
    LBNiCheng: TLabel;
    EDName: TEdit;
    BTClose: TButton;
    UserList: TListBox;
    Panel14: TPanel;
    Panel17: TPanel;
    PnlMes: TPanel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label14: TLabel;
    IMFace: TImage;
    CheckBox1: TCheckBox;
    send: TButton;
    RxTalk: TRxRichEdit;
    CBFontColor: TComboBox;
    CBFontSize: TComboBox;
    CBName: TComboBox;
    Panel18: TPanel;
    Splitter2: TSplitter;
    Panel19: TPanel;
    Label15: TLabel;
    Button1: TButton;
    Button3: TButton;
    Chat_Content: TRxRichEdit;
    MyRich: TRxRichEdit;
    ClientSocket1: TClientSocket;
    PnlFace: TPanel;
    GroupBox1: TGroupBox;
    Image1: TImage;

    .......
    Image135: TImage;

    PnlLeft: TPanel;
    Label1: TLabel;
    CB2: TRzCheckBox;
    SpeedButton1: TSpeedButton;
    procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure BTCloseClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Chat_ContentChange(Sender: TObject);
    procedure MyRichChange(Sender: TObject);
    procedure RxTalkChange(Sender: TObject);
    procedure RxTalkKeyPress(Sender: TObject; var Key: Char);
    procedure sendClick(Sender: TObject);
    procedure UserListClick(Sender: TObject);
    procedure CBFontSizeChange(Sender: TObject);
    procedure IMFaceClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure Image2Click(Sender: TObject);

    ..........
    procedure Image135Click(Sender: TObject);

    procedure FormShow(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Label1Click(Sender: TObject);
    procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);

    procedure CB2Click(Sender: TObject);
    procedure CBFontColorChange(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
  public
    ///////////////////////聊天 室//////////////////////////
    procedure Act_SetQQFace;  //设置QQ表情
    procedure Act_InDll;    //注册dll文件
    function RightPosEx(const Substr,S: string): Integer; //右边查找字符位置
    Procedure Act_SetRxEditFace(Re:TRXRichedit;TemStr:String);//处理接收来的表情
    Procedure Act_SetRxSecTalk(Re:TRXRichedit;TemStr:String);  //处理悄悄话
    procedure Acr_SetSelfTalk(Re:TRXRichedit;TemStr,MyColor,MySize:String);//处理本屏悄悄话
    Function Act_CheckUserOnLine:Boolean;  //检测用户是否在线
    procedure Act_CheckUserList;   //插入聊天对象
    procedure Act_InserGif(FilePath:String;TemIndex:integer);
    procedure Act_DoWhileFace(Re:TRXRichedit;TemWidStr:WideString;LineCount:integer);
    /////////////////////////////////////
  end;

var
  FrmChatRoom: TFrmChatRoom;
  m_arrFace: array[0..999,0..1] of string;//保存表情数组
 
  GifPath:String;//表情路径
  TemFontColor:TColor;//聊天室接收字体颜色
  TemFontSize:integer;//聊天室接收字体大小
  FaceLeft,FaceTop:integer; //表情窗口位置
  FaceCount:integer;   //发送的表情数
implementation
uses UMain,URichEdit,UFrmDeskTop,UOALogin,UFrmChatInfo;
{$R *.dfm}

//向聊天室服务器发送登录请求
 // FrmChatRoom.clientsocket1.Socket.SendText('request~'+UserNiCheng);

procedure TFrmChatRoom.ClientSocket1Error(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
var
  msg: String;
begin

 case ErrorCode of
    10061: msg := '服务器没有启动 或 服务器端没有升级';
    10054: msg := '对方没开机'; //Timer1的定时时间大于60秒时才起作用
    10053: msg := '对方强行关闭' ;
    else   msg := '连接失败!';
  end;
  ErrorCode := 0;
  //showmessage(msg);
end;

procedure TFrmChatRoom.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
var
  strReceive,strCom,strContent,strUser,BeginStr:string;
  RiPos,i:integer;
  SetStr:String;
  MyFontColor,MyFontSize:String;
begin

    //获取服务器应答消息
    strReceive:=socket.ReceiveText;

    if Pos(#13#10,strReceive)> 0 then
    begin
      strReceive :=StringReplace(strReceive, #13#10,'', [rfReplaceAll]);
    end;
   
    //[黑色#10]
    if RightPosEx('[',strReceive) > 0 then
    begin
      RiPos:=RightPosEx('[',strReceive);
      SetStr:=Copy(strReceive,RiPos,Length(strReceive)-RiPos+1);
      MyFontColor:=Copy(SetStr,Pos('[',SetStr)+1,Pos('#',SetStr)-Pos('[',SetStr)-1);
      MyFontSize:=Copy(SetStr,Pos('#',SetStr)+1,Pos(']',SetStr)-Pos('#',SetStr)-1);

      if MyFontColor='红色' then
        TemFontColor:=clRed;
      if MyFontColor='黑色' then
        TemFontColor:=clBlack;
      if MyFontColor='蓝色' then
        TemFontColor:=clNavy;
      if MyFontColor='绿色' then
        TemFontColor:=clGreen;
      if MyFontColor='紫色' then
        TemFontColor:=clPurple;
      if MyFontColor='土黄' then
        TemFontColor:=clOlive;
      if MyFontColor='深红' then
        TemFontColor:=clMaroon;
      if MyFontColor='暗绿' then
        TemFontColor:=clTeal;
      if MyFontColor='灰色' then
        TemFontColor:=clGray;
      if MyFontColor='粉色' then
        TemFontColor:=clFuchsia;

      TemFontSize:=StrToInt(MyFontSize);
     
      strReceive:=Copy(strReceive,1,RiPos-1);
    end;
    //解析应答消息
    strCom:=copy(strReceive,1,pos('~',strReceive)-1);
    strContent:='';
    strUser:='';
    //根据应答消息类型进行处理
    //应答消息为新用户进入聊天室
    if strCom='add' then
      begin
        //重新构造用户列表
        UserList.Clear;
        UserList.Items.Add('所有人');
        UserList.ItemIndex:=0;
        strContent:=copy(strReceive,pos('~',strReceive)+1,length(strReceive)-pos('~',strReceive));
        repeat
         strUser:=copy(strContent,1,pos('~',strContent)-1);
         UserList.Items.Add(strUser);
         strContent:=copy(strContent,pos('~',strContent)+1,length(strContent)-pos('~',strContent));
        until strContent='';
        //更新聊天室聊天内容
        Chat_Content.SelStart:=Length(Chat_Content.Text);
        Chat_Content.SelLength:=Length(FormatDateTime('YYYY-MM-DD HH:mm:ss ',SysNow)+UserList.Items.Strings[UserList.Items.count-1]+' 进来了，大家欢迎！');
        Chat_Content.SelAttributes.Color:=clblue;
        Chat_Content.SelAttributes.Size:=10;
        Chat_Content.Lines.Add(FormatDateTime('YYYY-MM-DD HH:mm:ss ',SysNow)+UserList.Items.Strings[UserList.Items.count-1]+' 进来了，大家欢迎！');

        PnlMes.Visible:=True;
      end;
    //应答消息为用户离开聊天室
    if strCom='del' then
      begin
        // 'del~'+strNick+'~'
        strContent:=copy(strReceive,pos('~',strReceive)+1,length(strReceive)-pos('~',strReceive));
        strUser:=copy(strContent,1,pos('~',strContent)-1);
        //更新聊天室内容
        for i:=0 to UserList.Items.Count - 1 do
        begin
          if UserList.Items.Strings[i]= strUser then
          begin
            Chat_Content.SelStart:=Length(Chat_Content.Text);
            Chat_Content.SelLength:=Length(FormatDateTime('YYYY-MM-DD HH:mm:ss ',SysNow)+strUser+'离开了...');
            Chat_Content.SelAttributes.Color:=clRed;
            Chat_Content.SelAttributes.Size:=10;
            Chat_Content.Lines.Add(FormatDateTime('YYYY-MM-DD HH:mm:ss ',SysNow)+strUser+'离开了...');
            UserList.Items.Delete(UserList.Items.IndexOf(strUser));
            Break;
          end;
       end;
      end;

    //应答消息为聊天内容
    if strCom='talk' then
      begin
        //获取聊天内容
        strContent:=copy(strReceive,pos('~',strReceive)+1,length(strReceive)-pos('~',strReceive));
        //更新聊天室内容显示
        //Chat_Content.Lines.Add(strContent);
       
        if Pos('对你悄悄地说',strContent) > 0 then
        begin
          BeginStr:=Copy(strContent,1,Pos(':',strContent));
          strContent:=copy(strContent,pos(':',strContent)+1,length(strContent)-pos(':',strContent));

          Act_SetRxSecTalk(MyRich,'TimeBegin#'+FormatDateTime('YYYY-MM-DD HH:mm:ss',SysNow)+' '+BeginStr);
          Act_SetRxSecTalk(MyRich,strContent);

          if ChatFlag=False then
          begin
            if ChatMsgFlag then
            begin
              FrmMain.MSNChat.Text:='新聊天消息';
              FrmMain.MSNChat.Title:='有悄悄话';
              FrmMain.MSNChat.ShowPopUp;
              Frmmain.LBChat.Caption:='有新的聊天室信息';
            end;
          end;
        end
        else
        begin
          //Act_SetRxSecTalk(Chat_Content,strContent);
          BeginStr:=Copy(strContent,1,Pos(':',strContent));
          strContent:=copy(strContent,pos(':',strContent)+1,length(strContent)-pos(':',strContent));

          Act_SetRxEditFace(Chat_Content,'TimeBegin#'+FormatDateTime('YYYY-MM-DD HH:mm:ss',SysNow)+' '+BeginStr);
          Act_SetRxEditFace(Chat_Content,strContent);
         
          if ChatFlag=False then
          begin
            if ChatMsgFlag then
            begin
              FrmMain.MSNChat.Text:='新聊天消息';
              FrmMain.MSNChat.Title:='有公共消息';
              FrmMain.MSNChat.ShowPopUp;
              FrmMain.LBChat.Caption:='有新的聊天室信息';
            end;
          end;
        end;
      end;
    //应答消息为登录错误 
    if strCom='err' then
    begin
      //获取消息内容
      strContent:=copy(strReceive,pos('~',strReceive)+1,length(strReceive)-pos('~',strReceive));
      //提示用户错误
      showmessage('<'+strContent+'>'+'这个昵称已经存在，请换一个登录！');
     { repeat
       MyName:=inputbox('重新输入','请输入昵称','大力水手');
      until trim(MyName)<>'';
      //重新发送登录请求
      //EDName.Text:=MyName;
      //LBNiCheng.Caption:=Trim(EDName.Text);
      //clientsocket1.Socket.SendText('request~'+MyName);}
    end;

end;

 

procedure TFrmChatRoom.BTCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TFrmChatRoom.Button3Click(Sender: TObject);
begin
  MyRich.Clear;
end;

procedure TFrmChatRoom.Button1Click(Sender: TObject);
begin
  Chat_Content.Clear;
end;

procedure TFrmChatRoom.Chat_ContentChange(Sender: TObject);
begin
  SendMessage(Chat_Content.Handle,WM_VSCROLL,SB_PAGEDOWN,0);
end;

procedure TFrmChatRoom.MyRichChange(Sender: TObject);
begin
  SendMessage(MyRich.Handle,WM_VSCROLL,SB_PAGEDOWN,0);
end;

procedure TFrmChatRoom.RxTalkChange(Sender: TObject);
begin

  if CBFontColor.Text='红色' then
    RxTalk.SelAttributes.Color:=clRed;
  if CBFontColor.Text='黑色' then
    RxTalk.SelAttributes.Color:=clBlack;
  if CBFontColor.Text='蓝色' then
    RxTalk.SelAttributes.Color:=clNavy;
  if CBFontColor.Text='绿色' then
    RxTalk.SelAttributes.Color:=clGreen;
  if CBFontColor.Text='紫色' then
    RxTalk.SelAttributes.Color:=clPurple;

  if CBFontColor.Text='土黄' then
    RxTalk.SelAttributes.Color:=clOlive;
  if CBFontColor.Text='深红' then
    RxTalk.SelAttributes.Color:=clMaroon;
  if CBFontColor.Text='暗绿' then
    RxTalk.SelAttributes.Color:=clTeal;
  if CBFontColor.Text='灰色' then
    RxTalk.SelAttributes.Color:=clGray;
  if CBFontColor.Text='粉色' then
    RxTalk.SelAttributes.Color:=clFuchsia;
   
  RxTalk.SelAttributes.Size:=StrToInt(CBFontSize.Text);
  //RxTalk.SelStart:=Length(RxTalk.Text);

end;

 

procedure TFrmChatRoom.RxTalkKeyPress(Sender: TObject; var Key: Char);
begin
  if Key=char(13) then
    send.Click;
end;

 

procedure TFrmChatRoom.sendClick(Sender: TObject);
var
  strFriend,TalkStr:string;
begin
  //检查发送消息内容是否为空

  {if Pos(#13,RXTalk.Text)> 0 then
  begin
    RXTalk.Text :=StringReplace(RXTalk.Text, #13,'', [rfReplaceAll]);
  end;}

  if Act_CheckUserOnLine = False then
  begin
    MessageBox(Handle,'该用户已下线或不存在','提示',MB_OK);
    CBName.Text:='所有人';
    Exit;
  end;

  if Length(RXTalk.Text) = 0 then
  begin
    MessageBox(Handle,'请输入要发送的内容','提示',MB_OK);
    exit;
  end;
 
  if EDName.Text='' then
  begin
    MessageBox(Handle,'您还没有登陆，请登陆','提示',MB_OK);
    EDName.SetFocus;
    Exit;
  end;

  if UserList.Items.Count = 0 then
  begin
    MessageBox(Handle,'您还没有登陆，不能发送信息','提示',MB_OK);
    exit;
  end;
  //根据用户选择的聊天对象，向聊天室服务器发送广播请求

  Act_CheckUserList;

  TalkStr:=ConvertMsgToCmd(RxTalk); //表情转换成命令字符串

  {if (Length(TalkStr)*StrToInt(CBFontSize.Text)) > 1000 then
  begin
    MessageBox(Handle,'输入字数过长','提示',MB_OK);
    RxTalk.SelStart:=Length(RxTalk.Text);
    Exit;
  end;}
 
  {if UserList.ItemIndex=0 then
  begin
    clientsocket1.Socket.SendText('public~'+MyName+' 对大家说：'+TalkStr+'['+CBFontColor.Text+'#'+CBFontSize.Text+']');
    RXTalk.Clear;
    exit;
  end ; }

  strFriend:=Trim(CBName.Text);  //聊天对象

  if CheckBox1.Checked = false then
  begin
    if MyName= strFriend  then
      clientsocket1.Socket.SendText('public~'+MyName+' 自言自语道:'+TalkStr+'['+CBFontColor.Text+'#'+CBFontSize.Text+']')
    else
    begin
      clientsocket1.Socket.SendText('public~'+MyName+'~'+strFriend+'~'+TalkStr+'['+CBFontColor.Text+'#'+CBFontSize.Text+']');

      if (CBName.Text<>'所有人')  then
      begin

        Acr_SetSelfTalk(Chat_Content,'TimeBegin#'+FormatDateTime('YYYY-MM-DD HH:mm:ss',SysNow)+' 你 对 '+CBName.Text+' 说:',CBFontColor.Text,CBFontSize.Text);

        Acr_SetSelfTalk(Chat_Content,TalkStr,CBFontColor.Text,CBFontSize.Text);
      end;
    end;
  end
  else
     //如果用户选择私聊，向服务器发送私聊请求
  begin
    clientsocket1.Socket.SendText('private~'+MyName+'~'+strFriend+'~'+MyName+' 对你悄悄地说:'+TalkStr+'['+CBFontColor.Text+'#'+CBFontSize.Text+']');

    if (CBName.Text<>'所有人')  then
    begin
      Acr_SetSelfTalk(MyRich,'TimeBegin#'+FormatDateTime('YYYY-MM-DD HH:mm:ss',SysNow)+' 你 对 '+CBName.Text+' 悄悄地说:',CBFontColor.Text,CBFontSize.Text);

      Acr_SetSelfTalk(MyRich,TalkStr,CBFontColor.Text,CBFontSize.Text);
    end;
  end;

 RxTalk.Clear;
 RxTalk.SetFocus;
end;


 

已投稿到： 排行榜 圈子
阅读|评论|收藏|打印|举报
前一篇：Delphi 清空文件夹
后一篇：Delphi 聊天室（带QQ表情）--Client端(2)
评论    重要提示：警惕虚假中奖信息，点击查看详情[发评论]
  • 评论加载中，请稍候...
发评论    明星私家相册

验证码：看不清楚数字吗？点击这里再试试。收听验证码

发评论

以上网友发言只代表其个人观点，不代表新浪网的观点或立场。

相关博文
读取中...
推荐博文
读取中...