chatfrm.pas

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

var
  AClientData: TxClientData;
  VChatProperty: PxChatProperty;
  AText: PChar;
  VCount: Integer;
begin
  Data.Read(AClientData, SizeOf(AClientData));
  VCount := Data.Size - SizeOf(TxClientData) * 2 - SizeOf(MessageID);
  AText := StrAlloc(VCount);
  Data.Seek(SizeOf(AClientData), soFromCurrent);
  Data.Read(AText^, VCount);

  if ListBoxChat.Items.Count > MAX_CHAT_RECORD then
  begin
    ListBoxChat.Clear;
    while FChatPropertyList.Count > 0 do
      FChatPropertyList.Remove(FChatPropertyList.Last);
  end;
  if chbShowTime.Checked then
    ListBoxChat.Items.Add(AText + ' {' + FormatDateTime('hh:nn',Now) + '}')
  else
    ListBoxChat.Items.Add(AText);

  New(VChatProperty);
  VChatProperty^.FontColor := AClientData.FontColor;
  VChatProperty^.Expression := AClientData.Expression;
  VChatProperty^.BKColor := AClientData.BKColor;
  VChatProperty^.NickName := AClientData.NickName + '： ';
  VChatProperty^.Portrait := AClientData.Portrait;
  FChatPropertyList.Add(VChatProperty);

  SendMessage(ListBoxChat.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;

procedure TChatClientForm.ReceiveBMessage(Data: TMemoryStream);
var
  AClientData: TxClientData;
  VChatProperty: PxChatProperty;
  AText: PChar;
  VCount: Integer;
begin
  Data.Read(AClientData, SizeOf(AClientData));
  VCount := Data.Size - SizeOf(TxClientData) * 2 - SizeOf(MessageID);
  AText := StrAlloc(VCount);
  Data.Seek(SizeOf(AClientData), soFromCurrent);
  Data.Read(AText^, VCount);

  if ListBoxChat.Items.Count > MAX_CHAT_RECORD then
  begin
    ListBoxChat.Clear;
    while FPerChatPropertyList.Count > 0 do
      FPerChatPropertyList.Remove(FPerChatPropertyList.Last);
  end;
  ListBoxChat.Items.Add(AText);

  New(VChatProperty);
  VChatProperty^.FontColor := AClientData.FontColor;
  VChatProperty^.Expression := AClientData.Expression;
  VChatProperty^.BKColor := AClientData.BKColor;
  VChatProperty^.NickName := AClientData.NickName + '： ';
  VChatProperty^.Portrait := AClientData.Portrait;
  FPerChatPropertyList.Add(VChatProperty);

  SendMessage(ListBoxChat.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;

procedure TChatClientForm.ListBoxChatMeasureItem(Control: TWinControl;
  Index: Integer; var Height: Integer);
var
  ARect: TRect;
begin
  ARect := Rect(0, 0, 10, 10);
  Height := DrawText(ListBoxChat.Canvas.Handle, PChar(ListBoxChat.Items[Index]), Length(ListBoxChat.Items[Index]), ARect,
      DT_VCENTER or DT_NOPREFIX or DT_CALCRECT) + 8;
end;

procedure TChatClientForm.ListBoxChatDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  ARect: TRect;
  ALen: Integer;
begin
  if Index < ListBoxChat.Items.Count then
  begin

    ARect := Rect;
    ARect.Right := 20;
    ListBoxChat.Canvas.Brush.Color := clWhite;
    ListBoxChat.Canvas.FillRect(ARect);

    ImageListPortraitS.Draw(ListBoxChat.Canvas, Rect.Left + 2, Rect.Top + 2, PxChatProperty(FChatPropertyList.Items[Index])^.Portrait);
    ListBoxChat.Canvas.Brush.Color := PxChatProperty(FChatPropertyList.Items[Index])^.BKColor;
    Inc(Rect.Left, 20);
    ListBoxChat.Canvas.FillRect(Rect);
    Inc(Rect.Top, 4);
    Inc(Rect.Left, 4);
    ListBoxChat.Canvas.Font.Color := PxChatProperty(FChatPropertyList.Items[Index])^.FontColor;
    ALen := Length(PxChatProperty(FChatPropertyList.Items[Index])^.NickName);
    DrawText(ListBoxChat.Canvas.Handle, PChar(PxChatProperty(FChatPropertyList.Items[Index])^.NickName), ALen, Rect,
      DT_VCENTER or DT_NOPREFIX);

    Inc(Rect.Left, ListBoxChat.Canvas.TextWidth(PxChatProperty(FChatPropertyList.Items[Index])^.NickName));
    if PxChatProperty(FChatPropertyList.Items[Index])^.Expression <> 0 then
    begin
      Dec(Rect.Top, 4);
      ImageListExpression.Draw(ListBoxChat.Canvas, Rect.Left + 2, Rect.Top + 2, PxChatProperty(FChatPropertyList.Items[Index])^.Expression);
      Inc(Rect.Left, 20);
      Inc(Rect.Top, 4);
    end;
    DrawText(ListBoxChat.Canvas.Handle, PChar(ListBoxChat.Items[Index]), Length(ListBoxChat.Items[Index]), Rect,
      DT_VCENTER or DT_NOPREFIX);
  end;
end;

procedure TChatClientForm.MemoChatKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if FClearText then
  begin
    MemoChat.Clear;
    FClearText := False;
  end;
end;

procedure TChatClientForm.ListBoxChatDblClick(Sender: TObject);
begin
  MemoChat.Lines.Add(ListBoxChat.Items[ListBoxChat.ItemIndex]);
  MemoChat.SetFocus;
end;
        
procedure TChatClientForm.btnSendMsgClick(Sender: TObject);
var
  AKey: Word;
begin
  AKey := VK_RETURN;
  MemoChatKeyDown(Sender, AKey, [ssCtrl]);
  MemoChatKeyUp(Sender, AKey, [ssCtrl]);
  if Self.Showing then
    MemoChat.SetFocus;
end;

procedure TChatClientForm.ClientListBoxMeasureItem(Control: TWinControl;
  Index: Integer; var Height: Integer);
var
  ARect: TRect;
begin
  ARect := Rect(0, 0, 10, 10);
  Height := DrawText(ClientListBox.Canvas.Handle, PChar(ClientListBox.Items[Index]), Length(ClientListBox.Items[Index]), ARect,
      DT_VCENTER or DT_NOPREFIX or DT_CALCRECT) + 8;
end;

procedure TChatClientForm.ClientListBoxDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  if Index < ClientListBox.Items.Count then
  begin
    if odFocused in State then
    begin
      if Index = ClientListBox.ItemIndex then
        ClientListBox.Canvas.Brush.Color := clBackground
      else
        ClientListBox.Canvas.Brush.Color := $00ECE8E3;

      ClientListBox.Canvas.FillRect(Rect);
      ImageListPortraitS.Draw(ClientListBox.Canvas, Rect.Left + 2, Rect.Top + 2, PxClientData(FClientDataList.Items[Index])^.Portrait);
      Inc(Rect.Top, 4);
      Inc(Rect.Left, 24);
      ClientListBox.Canvas.Font.Color := clwhite;
      DrawText(ClientListBox.Canvas.Handle, PChar(ClientListBox.Items[Index]), Length(ClientListBox.Items[Index]), Rect,
        DT_VCENTER or DT_NOPREFIX);
    end
    else begin
      if Index = ClientListBox.ItemIndex then
        ClientListBox.Canvas.Brush.Color := clBackground
      else
        ClientListBox.Canvas.Brush.Color := $00ECE8E3;

      ClientListBox.Canvas.FillRect(Rect);
      ImageListPortraitS.Draw(ClientListBox.Canvas, Rect.Left + 2, Rect.Top + 2, PxClientData(FClientDataList.Items[Index])^.Portrait);
      Inc(Rect.Top, 4);
      Inc(Rect.Left, 24);
      ClientListBox.Canvas.Font.Color := clBlack;
      DrawText(ClientListBox.Canvas.Handle, PChar(ClientListBox.Items[Index]), Length(ClientListBox.Items[Index]), Rect,
        DT_VCENTER or DT_NOPREFIX);
    end;
  end;
end;

{=======================================================}
{ 登录请求 }

function TChatClientForm.RequestLogin;
begin
  try
    SendConnectRequest(UDPClient);
  except
    Result := False;
    Exit;
  end;
  Result := RequestTimeout;
end;

{=======================================================}
{ 请求收取在线用户资料 }

function TChatClientForm.RequestClientData: Boolean;
begin
  try
    SendClientData(UDPClient);
  except
    Result := False;
    Exit;
  end;
  Result := RequestTimeout;
end;

procedure TChatClientForm.SendConnectRequest(Socket: TIdUDPClient);
begin
  MessageID := xMIDConnect;
  FSendStream.Clear;
  FSendStream.Write(MessageID, SizeOf(MessageID));
  Socket.SendBuffer(ServerAddress, UDPServerPort, FSendStream.Memory^, FSendStream.Size);
end;

procedure TChatClientForm.SendClientData(Socket: TIdUDPClient);
begin
  MessageID := xMIDClientData;
  FSendStream.Clear;
  FSendStream.Write(MessageID, SizeOf(MessageID));
  FSendStream.Write(xClientData, SizeOf(xClientData));
  Socket.SendBuffer(ServerAddress, UDPServerPort, FSendStream.Memory^, FSendStream.Size);
end;

procedure TChatClientForm.ReceiveClientData(Data: TMemoryStream);
var
  VClientData: PxClientData;
  Vi, VCount: Integer;
begin
  Data.Read(VCount, SizeOf(VCount));
  for Vi := 0 to VCount - 1 do
  begin
    New(VClientData);
    FClientDataList.Add(VClientData);
    Data.Read(VClientData^, SizeOf(TxClientData));
    ClientListBox.Items.Add(VClientData^.NickName);
    if Vi = VCount - 1 then
      Move(VClientData^, xClientData, SizeOf(xClientData));
  end;
end;

procedure TChatClientForm.UDPServerUDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
begin
  if FExiting then Exit;
  FReceiveStream.Clear;
  FReceiveStream.LoadFromStream(AData);
  FReceiveStream.Read(MessageID, SizeOf(MessageID));

  case MessageID of
     xMIDConnectS: begin
       FControlFlag := True;
     end;
     xMIDClientDataS: begin
       ReceiveClientData(FReceiveStream);
       FControlFlag := True;
     end;
     xMIDClientCheck: begin
       MessageID := xMIDClientCheckS;
       FSendStream.Clear;
       FSendStream.Write(MessageID, SizeOf(MessageID));
       UDPClient.SendBuffer(ABinding.PeerIP, UDPClientServerPort, FSendStream.Memory^, FSendStream.Size);
     end;
     xMIDClientCheckS: begin
       FControlFlag := True;
     end;
     xMIDClientData: begin
       ReceiveNClientData(FReceiveStream);
       PlaySound('SOUND_GLOBAL', 0, SND_RESOURCE or SND_ASYNC);
     end;
     xMIDChat: begin
       ReceiveMessage(FReceiveStream);
       PlaySound('SOUND_MSG', 0, SND_RESOURCE or SND_ASYNC);
     end;
     xMIDBChat: begin
       ReceiveBMessage(FReceiveStream);
       PlaySound('SOUND_MSG', 0, SND_RESOURCE or SND_ASYNC);
     end;
     xMIDClientLogout: begin
       ReceiveLogout(FReceiveStream);
       PlaySound('SOUND_SYSTEM', 0, SND_RESOURCE or SND_ASYNC);
     end;
     xMIDServerExit: begin
       Self.Hide;
       Delay(2000);
       Close;
     end;
  end;
end;

function TChatClientForm.RequestTimeout: Boolean;
var
  FirstTickCount, Now: Longint;
begin
  FirstTickCount := GetTickCount;
  FControlFlag := False;
  repeat
    Application.ProcessMessages;
    Now := GetTickCount;
  until (Now - FirstTickCount >= CRECIEVETIMEOUT) or (Now < FirstTickCount) or FControlFlag;
  Result := FControlFlag;
end;

procedure TChatClientForm.ReceiveNClientData(Data: TMemoryStream);
var
  VClientData: PxClientData;

begin
  New(VClientData);
  FClientDataList.Add(VClientData);
  Data.Read(VClientData^, SizeOf(TxClientData));
  ClientListBox.Items.Add(VClientData^.NickName);
end;

procedure TChatClientForm.ReceiveLogout(Data: TMemoryStream);
var
  VClientData: PxClientData;
  Vi: Integer;
begin
  New(VClientData);
  Data.Read(VClientData^, SizeOf(TxClientData));

  for Vi := 0 to FClientDataList.Count - 1 do
  begin
    if PxClientData(FClientDataList.Items[Vi])^.ClientID = VClientData^.ClientID then
    begin
      ClientListBox.Items.Delete(Vi);
      FClientDataList.Remove(FClientDataList.Items[Vi]);
      if ClientListBox.Items.Count - 1 < FFriendClient then
      begin
        Dec(FFriendClient);
        ClientListBox.ItemIndex := FFriendClient;
      end
      else
        ClientListBox.ItemIndex := FFriendClient;
      Break;
    end;
  end;
  Dispose(VClientData);
end;

procedure TChatClientForm.ToolButtonExpressionClick(Sender: TObject);
begin
  ListBoxChat.Clear;
  while FChatPropertyList.Count > 0 do
    FChatPropertyList.Remove(FChatPropertyList.Last);
end;

procedure TChatClientForm.ExpresstionChange(Sender: TObject);
begin
  xClientData.Expression := Expresstion.ItemIndex;
  MemoChat.SetFocus;
end;

procedure TChatClientForm.btnMsgModalClick(Sender: TObject);
begin
  if btnMsgModal.Caption = '消息模式(&W)' then
  begin
    btnMsgModal.Caption := '对话模式(&W)';
    ListBoxChat.Visible := False;
  end
  else
  begin
    btnMsgModal.Caption := '消息模式(&W)';
    ListBoxChat.Visible := True;
  end;
end;

procedure TChatClientForm.btnHideNameListClick(Sender: TObject);
begin
  if btnHideNameList.Caption = '隐藏名单(&N)' then
  begin
    btnHideNameList.Caption := '显示名单(&N)' ;
    pnlNameList.Visible := False;
    Splitter1.Visible := False;
  end
  else
  begin
    btnHideNameList.Caption := '隐藏名单(&N)' ;
    pnlNameList.Visible := True;
    Splitter1.Visible := True;
  end;
end;

procedure TChatClientForm.ClientListBoxClick(Sender: TObject);
begin
  FFriendClient := ClientListBox.ItemIndex;
  ClientListBox.Repaint;
  MemoChat.SetFocus;
end;

procedure TChatClientForm.FormShow(Sender: TObject);
begin
  ChatClientForm.InitChatRoom;
  MemoChat.SetFocus;
  FClearText := False;
end;

procedure TChatClientForm.btnCloseClick(Sender: TObject);
begin
  Self.Close;
end;

procedure TChatClientForm.FormDeactivate(Sender: TObject);
begin
  Close;
end;

procedure TChatClientForm.BroadCastClick(Sender: TObject);
begin
  MemoChat.SetFocus;
end;

end.