chat.~pas

简单的delphi udp聊天系统,简单的delphi udp聊天系统

unit chat;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ComCtrls, ImgList, IdUDPServer,IdSocketHandle,
  IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient, ExtCtrls;

type
tcommblock=record
sendername,msg:string[100];
//传递字体编号
MsgFontnameno:integer;
//传递字体大小
MsgFontsize:integer;
//传递字体颜色编号
MsgFontcolor:integer;
{传递字体风格编号（自定义1为加粗，3为倾斜，5为加下划线，
其他几种组合是各数相加之和，如加入下划线的粗体字传递的
参数为5（加下划线）＋1（加粗）＝6）
 }
Msgfontstyle:integer;
nowstr:string[20];
end;
  TMainForm = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    remoteip: TEdit;
    remoteport: TEdit;
    localname: TEdit;
    nickname: TEdit;
    bitset: TBitBtn;
    FontName: TComboBox;
    FontSize: TEdit;
    UpDown1: TUpDown;
    ColorBox1: TColorBox;
    ColorBox2: TColorBox;
    Bold: TSpeedButton;
    Italic: TSpeedButton;
    Underline: TSpeedButton;
    InputBox: TEdit;
    bitsend: TBitBtn;
    chatlog: TRichEdit;
    IdUDPClient1: TIdUDPClient;
    IdUDPServer1: TIdUDPServer;
    ImageList1: TImageList;
    close1: TSpeedButton;
    SpeedButton1: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure bitsetClick(Sender: TObject);
    procedure bitsendClick(Sender: TObject);
    procedure IdUDPServer1UDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
    procedure BoldClick(Sender: TObject);
    procedure ItalicClick(Sender: TObject);
    procedure UnderlineClick(Sender: TObject);
    procedure ColorBox2Change(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure InputBoxKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure close1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
procedure FontChange(comm:tcommblock;devicename:TRichEdit);
  end;
const
ReceiveTimeout=5000;

var
  MainForm: TMainForm;


implementation

uses denglu, rpd, DataM, ADODB, DB;

   {$R *.dfm}
   var
   bol:char='0';ita:char='0';unl:char='0';

procedure TMainForm.FontChange(comm:tcommblock;devicename:tRichEdit);
 begin
 with MainForm do
 with devicename do
 begin
 chatlog.Lines.add('('+comm.nowstr+')'+comm.sendername+':'+comm.msg);
 SelStart:=FindText('('+comm.nowstr+')'+comm.sendername+':'+comm.msg,0,length(text),[stmatchCase]);
 SelLength:=length(Text)-SelStart;
 SelAttributes.Name:=Fontname.Items[comm.MsgFontnameno];
 SelAttributes.Size:=comm.MsgFontsize;
 SelAttributes.Color:=colorbox1.colors[comm.MsgFontcolor];
 SelAttributes.Style:=[];
 if comm.MsgFontstyle in [1,4,6,9] then
 SelAttributes.Style:=SelAttributes.Style+[fsBold];
 if comm.MsgFontstyle in [3,4,8,9] then
 SelAttributes.Style:= SelAttributes.Style+[fsItalic];
 if comm.MsgFontstyle in [5,6,8,9] then
 SelAttributes.Style:=SelAttributes.Style+[fsUnderLine];
 end;
 end;
 function EnumFontsProc(var LogFont:TLogFont; var textMetric:TTextMetric;FontType:Integer;Data:Pointer):Integer;
 stdcall;
 begin
 TStrings(Data).Add(LogFont.lfFaceName);
 Result:=1;
 end;

 procedure Get_Fonts;
 var
 DC:HDC;
 begin
 DC:=GetDC(0);
 EnumFonts(DC,nil,@EnumFontsProc,Pointer(MainForm.FontName.Items));
 //调用windowsAPI 方法实现将windows字体名传入FontName组合框中
 ReleaseDC(0,DC);
 MainForm.FontName.Sorted:=True;
 end;
 procedure TMainForm.FormCreate(Sender: TObject);
begin
 Get_Fonts;
end;




procedure TMainForm.bitsetClick(Sender: TObject);
begin
if remoteip.Text='' then
begin
Application.MessageBox('远程IP不能为空','温馨提示！',MB_OK+MB_ICONWARNING);
remoteip.SetFocus;
end
else if remoteport.Text='' then
begin
Application.MessageBox('远程端口不能为空','温馨提示！',MB_OK+MB_ICONWARNING);
remoteport.SetFocus;
end
else if localname.Text='' then
begin
Application.MessageBox('本地端口不能为空','温馨提示！',MB_OK+MB_ICONWARNING);
localname.SetFocus;
end
else
begin
//连接到的服务器的主机名或IP地址
idudpclient1.Host:=remoteip.Text;
//设置目的主机的端口号。UDP服务器在该端口号监听
idudpclient1.Port:=strtoint(remoteport.Text);
//设置超时链接的毫秒数，用前面定义的常量设置
idudpclient1.ReceiveTimeout:=ReceiveTimeout;
//设置本地UDP服务器的监听端口号
idudpserver1.Active:=true;
//激活BitSend按钮
bitsend.Enabled:=true;
with dm.ADOQuery1 do
begin //聊天前记录当前用户的信息
close;
sql.Clear;
sql.Add('insert into CurrentUser values (:Curr_Name,:IP_Number,:Post_Number)');
Parameters.ParamByName('Curr_Name').Value:=nickname.Text;
Parameters.ParamByName('IP_Number').Value:=remoteip.Text;
Parameters.ParamByName('Post_Number').Value:=localname.Text;
ExecSQL;
end;

end;
end;

procedure TMainForm.bitsendClick(Sender: TObject);
var
comm:tcommblock;//定义通信结构变量
begin
comm.sendername:=nickname.Text;
comm.msg:=InputBox.Text;
comm.MsgFontnameno:=FontName.ItemIndex;
comm.MsgFontsize:=strtoint(fontsize.Text);
comm.nowstr:=datetimetostr(Now);
comm.MsgFontcolor:=colorbox1.ItemIndex;
comm.Msgfontstyle:=strtoint(bol)+
strtoint(ita)+strtoint(unl);
idudpclient1.SendBuffer(comm,sizeof(comm));
//调用fontchange过程，在本地用户聊天记录上显示信息对
//字体属性按用户定义的形式进行修改
fontchange(comm,chatlog);
InputBox.Text:='';
end;


procedure TMainForm.IdUDPServer1UDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
  var
  comm:tcommblock;//定义通信结构变量
begin
adata.ReadBuffer(comm,adata.Size);
//调用fontchange过程，在本地用户聊天记录上显示信息对字体
//属性按用户自定义的形式进行修改
fontchange(comm,chatlog);
end;

procedure TMainForm.BoldClick(Sender: TObject);
begin
if bol='1' then
begin
bold.Down:=false;
bol:='0';
end
else
begin
bold.Down:=true;
bol:='1';
end;
end;

procedure TMainForm.ItalicClick(Sender: TObject);
begin
if ita='3'then
begin
italic.Down:=false;
ita:='0';
end
else
begin
italic.Down:=true;
ita:='3';
end;
end;

procedure TMainForm.UnderlineClick(Sender: TObject);
begin
if unl='5' then
begin
underline.Down:=false;
unl:='0';
end
else
begin
underline.Down:=true;
unl:='5';
end;
end;

procedure TMainForm.ColorBox2Change(Sender: TObject);
begin
chatlog.Color:=colorbox2.Selected;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
close;
end;

procedure TMainForm.InputBoxKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if key=13 then
bitsend.Click;
end;

procedure TMainForm.close1Click(Sender: TObject);
begin
with dm.ADOQuery1 do
begin//推出时删除当前用户的信息
close;
sql.Clear;
sql.Add('delete from CurrentUser where Curr_User=:Curr_Name');
Parameters.ParamByName('Curr_Name').Value:=nickname.Text;
ExecSQL;
Close;
end;
application.Terminate;
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
loginform.ShowModal;
if loginform.ModalResult<>mrYes then
begin
Application.Terminate;
end;
end;

procedure TMainForm.SpeedButton1Click(Sender: TObject);
begin
RevampPassword.ShowModal;
end;

end.