chatfrm.pas

网上找到的使用UDP协议实现聊天的Delphi源码

{=======================================================}
{                                                       }
{          ZhaoSoft Messenger                           }
{                                                       }
{          版权所有 (c) 2005 赵建稳                     }
{                                                       }
{=======================================================}

unit ChatFrm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OleCtrls, ExtCtrls, StdCtrls, ComCtrls, ScktComp, xBASE, Buttons, ImgList, mmSystem,
  IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient,
  IdUDPServer, IdSocketHandle, ToolWin,WinSock,IniFiles; 

type
  TChatClientForm = class(TForm)
    ChatPanel: TPanel;
    MemoChat: TMemo;
    ListBoxChat: TListBox;
    UDPClient: TIdUDPClient;
    UDPServer: TIdUDPServer;
    ImageListPortraitS: TImageList;
    ImageListExpression: TImageList;
    pnlNameList: TPanel;
    ClientListBox: TListBox;
    StaticText1: TStaticText;
    Splitter1: TSplitter;
    Panel3: TPanel;
    btnSendMsg: TSpeedButton;
    Splitter2: TSplitter;
    btnMsgModal: TSpeedButton;
    Panel2: TPanel;
    LabelExpression: TLabel;
    Expresstion: TComboBoxEx;
    BroadCast: TCheckBox;
    btnHideNameList: TSpeedButton;
    chbShowTime: TCheckBox;
    btnClose: TSpeedButton;
    chbCloseAferSend: TCheckBox;
    chbAutoShow: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure MemoChatKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ListBoxChatMeasureItem(Control: TWinControl; Index: Integer;
      var Height: Integer);
    procedure ListBoxChatDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure MemoChatKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ListBoxChatDblClick(Sender: TObject);
    procedure btnSendMsgClick(Sender: TObject);
    procedure ClientListBoxMeasureItem(Control: TWinControl;
      Index: Integer; var Height: Integer);
    procedure ClientListBoxDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure UDPServerUDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
    procedure ToolButtonExpressionClick(Sender: TObject);
    procedure ExpresstionChange(Sender: TObject);
    procedure btnMsgModalClick(Sender: TObject);
    procedure btnHideNameListClick(Sender: TObject);
    procedure ClientListBoxClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure BroadCastClick(Sender: TObject);
  private
    FClearText: Boolean;
    FClientDataList: TList;
    FChatPropertyList: TList;
    FPerChatPropertyList: TList;
    FFriendClient: Integer;                     // 标记当前聊友
    FSendStream: TMemoryStream;                 // 用于发送消息
    FReceiveStream: TMemoryStream;              // 用于接收消息
    FControlFlag: Boolean;                      // 消息控制标记
    FConnecting: Boolean;                       // 已经连接服务器标记
    FExiting: Boolean;

    procedure ReceiveClientData(Data: TMemoryStream);
    procedure ReceiveNClientData(Data: TMemoryStream);
    procedure ReceiveMessage(Data: TMemoryStream);
    procedure ReceiveBMessage(Data: TMemoryStream);
    procedure ReceiveLogout(Data: TMemoryStream);
    // procedure SetChatEnable(Value: Boolean);
    function RequestTimeout: Boolean;
    function RequestLogin: Boolean;
    function RequestClientData: Boolean;
    procedure SendConnectRequest(Socket: TIdUDPClient);
    procedure SendClientData(Socket: TIdUDPClient);

  public
    procedure InitChatRoom;

    //服务器ＩＰ、昵称、头像
    procedure ChatRoomLogin(AServerIP,ANickName :string;APortrait :Integer);
  end;

const
  CRECIEVETIMEOUT = 1000;
  CUDPClientServerPort = 8848;
  CUDPServerPort = 8849;

var
  ChatClientForm: TChatClientForm;

implementation

{$R *.DFM}

{$R XSOUND.RES}

procedure TChatClientForm.InitChatRoom;
begin
  if FConnecting then Exit; 

  if RequestLogin then
  begin
    Delay(200);
    if RequestClientData then
    begin
      Expresstion.ItemIndex := 0;
      FConnecting := True;
    end; 
  end;
end;
{=======================================================}
  //聊天室登录信息
procedure TChatClientForm.ChatRoomLogin(AServerIP,ANickName :string;APortrait :Integer);
  function GetLocalIp(InternetIP:boolean):string;
    type
      TaPInAddr = array[0..10] of PInAddr;
      PaPInAddr = ^TaPInAddr;
    var
      phe: PHostEnt;
      pptr: PaPInAddr;
      Buffer: array[0..63] of Char;
      I: Integer;
      GInitData: TWSAData;
      IP: string;
  begin
      Screen.Cursor := crHourGlass;
      try
        WSAStartup($101, GInitData);
        IP:='0.0.0.0';
        GetHostName(Buffer, SizeOf(Buffer));
        phe := GetHostByName(buffer);
        if phe = nil then
        begin
          ShowMessage(IP);
          Result:=IP;
          Exit;
        end;
        pPtr := PaPInAddr(phe^.h_addr_list);
        if InternetIP then
          begin
            I := 0;
            while pPtr^[I] <> nil do
              begin
                IP := inet_ntoa(pptr^[I]^);
                Inc(I);
              end;
          end
        else
          IP := inet_ntoa(pptr^[0]^);
        WSACleanup;
        Result:=IP;
      finally
        Screen.Cursor := crDefault;
      end;
  end;
begin
  StrCopy(xClientData.NickName, PChar(ANickName));
  xClientData.FontColor := clBlack;
  xClientData.BKColor := clWhite;
  xClientData.Portrait := APortrait;
  xClientData.Expression := 0;
  StrPCopy(xClientData.IPAddress,GetLocalIp(True));
  xBASE.ServerAddress := AServerIP;
end;

procedure TChatClientForm.FormCreate(Sender: TObject);
var
  MyFile :TIniFile;
  ServerIp,UserName :string;
  Portrait :Integer;
begin
  try
    MyFile := TIniFile.Create(extractFilePath(Application.ExeName)+ '.\CONFIG.INI') ;
    ServerIp := MyFile.ReadString('Server','IP','127.0.0.1');
    UserName := MyFile.ReadString('Users','LastUser','匿名');
    Portrait :=  MyFile.ReadInteger('Users','Portrait',0);
    ChatRoomLogin(ServerIp,UserName,Portrait);
  finally
    if Assigned(MyFile) then MyFile.Free ;
  end;
  try
    UDPClientServerPort := CUDPClientServerPort;
    UDPServerPort := CUDPServerPort;
    UDPClient.ReceiveTimeout := CRECIEVETIMEOUT;
  except
    ChatClientForm.Free;
  end;
  FClientDataList := TList.Create;
  FChatPropertyList := TList.Create;
  FPerChatPropertyList := TList.Create;
  FReceiveStream := TMemoryStream.Create;
  FSendStream := TMemoryStream.Create;
  FConnecting := False;
  FExiting := False;
  FFriendClient := 0;//当前聊友
end;

{=======================================================}

procedure TChatClientForm.FormDestroy(Sender: TObject);

  procedure SendxMIDClientLogout;
  begin
    MessageID := xMIDClientLogout;
    FSendStream.Clear;
    FSendStream.Write(MessageID, SizeOf(MessageID));
    FSendStream.Write(xClientData, SizeOf(xClientData));
    UDPClient.SendBuffer(ServerAddress, UDPServerPort, FSendStream.Memory^, FSendStream.Size);
  end;

  procedure ObjectFree;
  begin
    while FPerChatPropertyList.Count > 0 do
      FPerChatPropertyList.Remove(FPerChatPropertyList.Last);
    while FChatPropertyList.Count > 0 do
      FChatPropertyList.Remove(FChatPropertyList.Last);
    while FClientDataList.Count > 0 do
      FClientDataList.Remove(FClientDataList.Last);
  end;
begin
  FExiting := True;
  if FConnecting then
    SendxMIDClientLogout;
  ObjectFree;

  FReceiveStream.Free;
  FSendStream.Free;
  FPerChatPropertyList.Free;
  FChatPropertyList.Free;
  FClientDataList.Free;
end;

{=======================================================}

procedure TChatClientForm.MemoChatKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  VCount: Integer;
  AText: PChar;
  VChatPropertyList: PxChatProperty;

  Vi,Vj: Integer;

  procedure SendxMIDClientLogout;
  begin
    MessageID := xMIDClientLogout;
    FSendStream.Clear;
    FSendStream.Write(MessageID, SizeOf(MessageID));
    FSendStream.Write((FClientDataList.Items[Vi])^, SizeOf(xClientData));
    UDPClient.SendBuffer(ServerAddress, UDPServerPort, FSendStream.Memory^, FSendStream.Size);
  end;

  procedure SendxMIDClientCheck;
  begin
    MessageID := xMIDClientCheck;
    FSendStream.Clear;
    FSendStream.Write(MessageID, SizeOf(MessageID));
    UDPClient.SendBuffer(PxClientData(FClientDataList.Items[Vi])^.IPAddress, UDPClientServerPort, FSendStream.Memory^, FSendStream.Size);
  end;

begin
  if ((ssCtrl in Shift) and (Chr(Key)='S')) or
    ((Key = VK_RETURN) and (ssCtrl in Shift) and BroadCast.Checked) then
  begin
    if Length(Trim(MemoChat.Text)) <= 0 then
      Exit;
    VCount := Length(MemoChat.Text);
    AText := StrAlloc(VCount + 1);
    Move(PChar(MemoChat.Text)^, AText^, VCount);
    AText[VCount] := #0;

    FSendStream.Clear;
    
    MessageID := xMIDChat;
    FSendStream.Write(MessageID, SizeOf(MessageID));
    FSendStream.Write(xClientData, SizeOf(xClientData));
    FSendStream.Write((FClientDataList.Items[FFriendClient])^, SizeOf(xClientData));
    FSendStream.Write(AText^, VCount + 1);
    Vj := FClientDataList.Count - 1;
    for Vi := 0 to Vj do
      UDPClient.SendBuffer(PxClientData(FClientDataList.Items[Vi])^.IPAddress, UDPClientServerPort, FSendStream.Memory^, FSendStream.Size);

    StrDispose(AText);
    FClearText := True;
    
    Vi := FFriendClient;

    if chbCloseAferSend.Checked then
    begin
      MemoChat.Clear;
      Self.Close;
    end;
    Exit;
  end;

  //根据CheckBox判断是私聊还是广播
  case Key of
    VK_RETURN: begin
      if (ssCtrl in Shift) then
      begin
        if Length(Trim(MemoChat.Text)) <= 0 then
          Exit;
          
        VCount := Length(MemoChat.Text);
        AText := StrAlloc(VCount + 1);
        Move(PChar(MemoChat.Text)^, AText^, VCount);
        AText[VCount] := #0;

        FSendStream.Clear;

        MessageID := xMIDChat;
        FSendStream.Write(MessageID, SizeOf(MessageID));
        FSendStream.Write(xClientData, SizeOf(xClientData));
        FSendStream.Write((FClientDataList.Items[FFriendClient])^, SizeOf(xClientData));
        FSendStream.Write(AText^, VCount + 1);
        UDPClient.SendBuffer(PxClientData(FClientDataList.Items[FFriendClient])^.IPAddress, UDPClientServerPort, FSendStream.Memory^, FSendStream.Size);

        if not BroadCast.Checked then
        begin
          if ListBoxChat.Items.Count > MAX_CHAT_RECORD then
          begin
            ListBoxChat.Clear;
            while FChatPropertyList.Count > 0 do
              FChatPropertyList.Remove(FChatPropertyList.Last);
          end;
          ListBoxChat.Items.Add('(发给' + PxClientData(FClientDataList.Items[FFriendClient])^.NickName + ')' + AText);
        end;

        FClearText := True;

        if not BroadCast.Checked then
        begin
          New(VChatPropertyList);
          VChatPropertyList^.FontColor := xClientData.FontColor;
          VChatPropertyList^.Expression := xClientData.Expression;
          VChatPropertyList^.BKColor := xClientData.BKColor;
          VChatPropertyList^.NickName := xClientData.NickName + '： ';
          VChatPropertyList^.Portrait := xClientData.Portrait;
          FChatPropertyList.Add(VChatPropertyList);
          SendMessage(ListBoxChat.Handle, WM_VSCROLL, SB_BOTTOM, 0);
        end;

        StrDispose(AText);

        Vi := FFriendClient;
        if PxClientData(FClientDataList.Items[Vi])^.ClientID <> xClientData.ClientID then
        begin
          SendxMIDClientCheck;
          if not RequestTimeout then
            SendxMIDClientLogout;
        end;

        //发送后关闭
        if chbCloseAferSend.Checked then
        begin
          MemoChat.Clear;
          Self.Close;
        end;

      end;
    end;

    VK_UP : begin  //选上一个人做聊天对象
      if (ssCtrl in Shift) then
      begin
        ClientListBox.ItemIndex := ClientListBox.ItemIndex -1;
        if ClientListBox.ItemIndex < 0 then ClientListBox.ItemIndex := ClientListBox.Count-1;
        ClientListBox.Repaint;
        FFriendClient := ClientListBox.ItemIndex;
      end;
    end;
    VK_DOWN : begin //选下一个人做聊天对象
      if (ssCtrl in Shift) then
      begin
        if ClientListBox.ItemIndex = ClientListBox.Count-1 then
          ClientListBox.ItemIndex := 0
        else
          ClientListBox.ItemIndex := ClientListBox.ItemIndex + 1;
        ClientListBox.Repaint;
        FFriendClient := ClientListBox.ItemIndex;
      end;
    end;
    VK_LEFT : begin  //选上一个表情
      if (ssCtrl in Shift) then
      begin
        Expresstion.ItemIndex := Expresstion.ItemIndex - 1;
        if Expresstion.ItemIndex < 0 then Expresstion.ItemIndex := Expresstion.Items.Count -1;
        xClientData.Expression := Expresstion.ItemIndex;
      end;
    end;
    VK_RIGHT : begin  //选下一个表情
      if (ssCtrl in Shift) then
      begin
        if Expresstion.ItemIndex = Expresstion.Items.Count -1 then
          Expresstion.ItemIndex := 0
        else
          Expresstion.ItemIndex := Expresstion.ItemIndex + 1;
        xClientData.Expression := Expresstion.ItemIndex;
      end;
    end;
  end;
end;

procedure TChatClientForm.ReceiveMessage(Data: TMemoryStream);