unitmsgsend.pas

delphi写的基于server和client的聊天源码 有参考意义

unit Unitmsgsend;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, XPMenu, Buttons, Menus,shellapi,
  ImgList,midas;
const
  WM_WZGLNOTIFY = WM_USER + 101;  //自定义消息
  strNotifyTip = '◆消息浏览◆';
  ID_MAIN = 200;
  const
  CM_RESTORE = WM_USER + $1000; {自定义的“恢复”消息}
  WZGL_APP_NAME = 'WZGL_System';
type
  Tfrmmsgsend = class(TForm)
    Panel1: TPanel;
    lview: TListView;
    Panel2: TPanel;
    Label1: TLabel;
    Label4: TLabel;
    mmsgmemo: TMemo;
    SpeedButton1: TSpeedButton;
    Timer1: TTimer;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    ImageList1: TImageList;
    Timer2: TTimer;
    SpeedButton2: TSpeedButton;
    Listvip: TListView;
    mgetmsg: TMemo;
    Label2: TLabel;
    edtmsguser: TLabeledEdit;
    PopupMenu2: TPopupMenu;
    N4: TMenuItem;
    N5: TMenuItem;
    XPMenu1: TXPMenu;
    lbhelp: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure lviewClick(Sender: TObject);
    procedure ListvipClick(Sender: TObject);
    procedure lviewCustomDrawItem(Sender: TCustomListView; Item: TListItem;
      State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure N5Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure lbhelpMouseEnter(Sender: TObject);
    procedure lbhelpMouseLeave(Sender: TObject);
    procedure lbhelpClick(Sender: TObject);
    procedure mmsgmemoKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
     function AddIcon(hwnd: HWND): Boolean; //在状态区添加图标
    function RemoveIcon(hwnd: HWND): Boolean; //从状态区移去图标
    procedure Notify(var Msg: TMessage); message WM_WZGLNOTIFY; //自定义消息处理函数
    procedure minimize(sender: Tobject); //定义最小化过程，赋给Application.OnMinimize
    procedure RestoreRequest(var message: TMessage); message CM_RESTORE;
    function yztjz(str:string):string; //验证套接字，TRUE返回字符串，FALSE返回‘1’
    procedure addlists(str1:string;str2:string);//写到表格；
    procedure addiplist(counted:integer;ip_str:string;comp_names:string);
  public
    { Public declarations }
  end;

var
  frmmsgsend: Tfrmmsgsend;
  nid: NOTIFYICONDATA;
  names,ipdz,fs_ip,fs_comp:string;
  warningflag:integer;
  flag:integer;
implementation

uses Unitmsgdm, Unitpulicsub, Unitbbs;

{$R *.dfm}
///////////////自定义函数/////////////////////////////////
////////////////////////////////////////{处理“恢复”消息}

procedure Tfrmmsgsend.RestoreRequest(var message: TMessage);
begin
  if IsIconic(Application.Handle) = True then  //窗体是否最小化
    Application.Restore  //恢复窗体
  else
    Application.BringToFront; //提到前面显示
end;
//在状态区添加图标
function Tfrmmsgsend.AddIcon(hwnd: HWND): Boolean;
begin
  nid.cbSize := sizeof(NOTIFYICONDATA);
  nid.Wnd := hwnd;
  nid.uID := iD_MAIN;
  nid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
  nid.uCallbackMessage := WM_WZGLNOTIFY;
  nid.hIcon := LoadIcon(hInstance, 'MAINICON');
  strCopy(nid.szTip, strNotifyTip);
  AddIcon := Shell_NotifyIcon(NIM_ADD, @nid);
end;

//从状态区移去图标
function Tfrmmsgsend.RemoveIcon(hwnd: HWND): Boolean;
var
  nid: NOTIFYICONDATA;
begin
  nid.cbSize := sizeof(NOTIFYICONDATA);
  nid.Wnd := hwnd;
  nid.uID := iD_MAIN ;
  nid.uFlags := 0;
  RemoveIcon := Shell_NotifyIcon(NIM_DELETE, @nid);
end;

//自定义消息处理函数
procedure Tfrmmsgsend.Notify(var Msg: TMessage);
var
  Pt: TPoint;
begin
  case msg.LParam of
    WM_RBUTTONDOWN:    //当点击右键时,弹出快捷菜单
      begin
        SetForeGroundWindow(nid.wnd);
        GetCursorPos(Pt);
        Popupmenu1.Popup(pt.x, pt.y);
      end;
  end;
end;

//定义最小化过程，赋给Application.OnMinimize;
procedure Tfrmmsgsend.minimize(sender: Tobject);
begin
  AddIcon(handle);
  ShowWindow(Application.handle, sw_hide)
end;

Procedure DoBleep (Freq : Word; MSecs : LongInt); //响声音;
Begin
  If MSecs<-1 Then MSecs:=0;
   Windows.Beep (Freq, MSecs);
End;
////////////////////////////////////////
procedure Tfrmmsgsend.FormClose(Sender: TObject; var Action: TCloseAction);
var
  bz,iped:widestring;
begin
  try
    bz:='2';
    iped:=ipdz;
    dm.SocketConn.AppServer.closed(bz,iped);
  finally
    action:=cafree;
  end;
end;

procedure Tfrmmsgsend.FormDestroy(Sender: TObject);
begin
  RemoveIcon(handle);
end;

procedure Tfrmmsgsend.N1Click(Sender: TObject);
begin
  RemoveIcon(handle);
  self.WindowState:=wsNormal;
  ShowWindow(Application.handle, SW_SHOWNORMAL);
end;

procedure Tfrmmsgsend.N2Click(Sender: TObject);
begin
  if application.MessageBox('是否关闭消息服务器！',pchar(application.Title),mb_iconquestion+mb_yesno)=idyes then
    begin
      application.Terminate;
    end;
end;

procedure Tfrmmsgsend.FormCreate(Sender: TObject);
begin
  application.OnMinimize:=minimize;
  warningflag:=1;
  flag:=0;
end;
////////////////////////////////////
function tfrmmsgsend.yztjz(str:string):string;
var
  comp1,comp2,str2,str3:string;
  i,len:integer;
begin
  comp1:=strupper(pchar(trim(ipdz+names)));
  len:=length(trim(comp1));
  str3:=copy(str,1,pos('p',str)-1);
  str2:=str3+copy(str,pos('p',str)+1,length(str)-(length(str3)+1));
  comp2:=strupper(pchar(copy(str2,1,len)));
  if StrComp(pchar(comp2),pchar(comp1))=0 then
  begin
    result:=copy(str,len+1,length(str));
  end else
  begin
    result:='1';
  end;
end;
procedure tfrmmsgsend.addlists(str1:string;str2:string);
var
  lists:tlistitem;
  strc,sname:string;
  i:integer;
begin
  i:=pos('p',str1);
  if i<>0 then
  begin
    sname:=copy(str1,pos('p',str1)+1,length(str1)-pos('p',str1));//取机器名
  end;
  i:=pos('p',str2);
  if i<>0 then
  begin
    strc:=copy(str2,pos('p',str1)+1,length(str2)-pos('p',str2));
  end;
  i:=pos('p',strc);
  if i<>0 then
  begin
    strc:=copy(strc,pos('p',strc)+1,length(strc)-pos('p',strc));
  end;
  if strc='' then
  begin
    strc:=str2;
  end;
  lists:=lview.Items.Add;
  lists.Caption:=trim(copy(str1,1,pos('p',str1)-1));
  lists.SubItems.Add((sname));
  lists.SubItems.Add(trim('null'));
  lists.SubItems.Add(trim(strc));
  lists.SubItems.Add (formatdatetime('hh'':''MM'':''ss',now));
  if flag=1 then
  begin
    lists.SubItems.Add ('发');
  end;
  if flag=2 then
  begin
    lists.SubItems.Add ('收');
  end;
  {flag:=0;}
end;
procedure Tfrmmsgsend.SpeedButton1Click(Sender: TObject);
var
  ipstr,values,sendobj:widestring;
begin
  if trim(mmsgmemo.Text)='' then
  begin
    application.MessageBox('请输入发送内容！',pchar(application.Title),mb_iconinformation);
    mmsgmemo.SetFocus;
    exit;
  end;
  ipstr:=trim(ipdz+'p'+names); //发送方
  values:=trim(mmsgmemo.Text);
  sendobj:= trim(fs_ip)+'p'+trim(fs_comp);  //接受套接字
  try    //容错处理
    dm.SocketConn.AppServer.sendmsg(sendobj,values,ipstr);
    flag:=1;
    addlists(trim(ipdz+'p'+names),trim(mmsgmemo.Text));
    mmsgmemo.Clear;
  except
    application.MessageBox('消息服务器发生故障！',pchar(application.Title),mb_iconwarning);
    flag:=1;
    addlists(trim(ipdz+'p'+names),trim(mmsgmemo.Text));
    mmsgmemo.Clear;
    warningflag:=0;
  end;
end;

procedure Tfrmmsgsend.FormShow(Sender: TObject);
var
  u,p,b,ii,n :widestring;
  fg,vips,vcounts,vname:olevariant;
  ips,compnames:string;
  counted:integer;
begin
  names:=GetComputerName;
  ipdz:=GetComputerip;
  u:='';
  p:='';
  b:='';
  ii:=ipdz;
  n:=names;
  try
    dm.SocketConn.AppServer.logined(u,p,b,ii,n,fg); //登陆服务器
    if fg=1 then
    begin
      try
        dm.SocketConn.AppServer.getips(vips,vname,vcounts);
        ips:=vartostr(vips);
        compnames:=vartostr(vname);
        counted:=strtoint(vartostr(vcounts));
        addiplist(counted,ips,compnames);
        timer1.enabled:=true;
        timer2.Enabled:=true;
      except
        application.MessageBox('加载在线用户列表出错！',pchar(application.Title),mb_iconwarning);
      end;
    end;
  finally
    timer2.Enabled:=true;
    timer1.Enabled:=true;
  end;
end;
procedure tfrmmsgsend.addiplist(counted:integer;ip_str:string;comp_names:string); //加载用户列表；
var
  itemed,oldstr,itemnames,oldname:string;
  i,j:integer;
  lists,oldlist:tlistitem;
begin
  itemed:=ip_str;
  itemed:=copy(itemed,pos('p',itemed)+1,length(itemed)-length(trim(oldstr))-1); //ip
  itemnames:=comp_names;
  itemnames:=copy(itemnames,pos('p',itemnames)+1,length(itemnames)-length(trim(oldname))-1); //computername;
  if counted<listvip.Items.Count then  //有某个客户锻退出时，就重新排列;
  begin
    listvip.Items.Clear;
  end;
  for i:=1 to counted do
  begin
    if i<>counted then
    begin
      oldstr:=copy(itemed,1,pos('p',itemed)-1);
      oldname:=copy(itemnames,1,pos('p',itemnames)-1);
    end else
    begin
      oldstr:=itemed;
      oldname:=itemnames;
    end;
    itemed:=copy(itemed,pos('p',itemed)+1,length(itemed)-length(trim(oldstr))-1);
    itemnames:=copy(itemnames,pos('p',itemnames)+1,length(itemnames)-length(trim(oldname))-1);
    oldlist:=listvip.FindCaption(0,trim(oldname)+'@'+trim(oldstr),true,true,true);
    if oldlist=nil then
    begin
      lists:=listvip.Items.Add;
      lists.Caption:=trim(oldname)+'@'+trim(oldstr);
      lists.ImageIndex:=2;
    end;
  end;
end;
procedure Tfrmmsgsend.Timer1Timer(Sender: TObject); //接收消息
var
  values1,values2:olevariant;
  strtjz,str:string;
  ipandname:widestring;
begin
  try
    ipandname:=trim(ipdz+'p'+names);
    dm.SocketConn.AppServer.getmsg(values1,values2,ipandname);
    str:= vartostr(values1);
    if not varisnull(values1) then
    begin
      flag:=2;
      addlists(vartostr(values2),str);
      DoBleep(1047, 100); //收到消息，声音提示！！
      DoBleep(1109, 100);
      DoBleep(1175, 100);
    end;
  except
    timer1.Enabled:=false;
    application.MessageBox('消息服务器发生故障！',pchar(application.Title),mb_iconwarning);
    warningflag:=0;
  end;
end;

procedure Tfrmmsgsend.Timer2Timer(Sender: TObject);
var
  vips,vcounts,vname:olevariant;
  counted:integer;
  ips,compnames:string;
begin
  try
    dm.SocketConn.AppServer.getips(vips,vname,vcounts);
    ips:=vartostr(vips);
    compnames:=vartostr(vname);
    counted:=strtoint(vartostr(vcounts));
    addiplist(counted,ips,compnames);
  except
    timer2.Enabled:=false;
    warningflag:=0;
    application.MessageBox('加载在线用户列表出错！',pchar(application.Title),mb_iconwarning);
    //dm.SocketConn.AppServer.getmsg(values1,values2);
  end;
end;

procedure Tfrmmsgsend.SpeedButton2Click(Sender: TObject);
begin
  frmbbs:=tfrmbbs.Create(self);
  if FileExists(ExtractFilePath(application.ExeName)+'download\lmmx.xml') then
  begin
    dm.Cdsggb.Open;
  end else
  begin
    dm.Cdsggb.Open;
  end;
  savedata(dm.Cdsggb,'lmmx.xml');
  frmbbs.ShowModal;
end;

procedure Tfrmmsgsend.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  if warningflag=0 then
  begin
    application.Terminate;
  end;
end;

procedure Tfrmmsgsend.lviewClick(Sender: TObject);
var
  lists:tlistitem;
begin
  if lview.Selected<> nil then
  begin
    lists:=lview.Selected;
    {lview.Hint:=lists.SubItems.Strings[2];}
    mgetmsg.Clear;
    mgetmsg.Lines.Add('发送方：'+lists.SubItems.Strings[0]+'        '+'接收时间：'+lists.SubItems.Strings[3]);
    mgetmsg.Lines.Add(lists.SubItems.Strings[2]);
  end else
  begin
    {lview.Hint:='';}
    mgetmsg.Text:='';
  end;
end;

procedure Tfrmmsgsend.ListvipClick(Sender: TObject);
var
  lists:tlistitem;
begin
  if listvip.Selected <>nil then
  begin
    lists:=listvip.Selected;
    fs_comp:=trim(copy(lists.Caption,1,pos('@',lists.Caption)-1));  //取ip (名字)
    fs_ip:=trim(copy(lists.Caption,pos('@',lists.Caption)+1,length(lists.Caption)-length(trim(fs_comp))-1)); //取computername ip
    edtmsguser.Text:='机器名：'+trim(fs_comp)+'   IP地址：'+trim(fs_ip);
  end;
end;

procedure Tfrmmsgsend.lviewCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if trim(item.SubItems.Strings[4])='收' then
  begin
    (Sender as TListView).Canvas.Font.Color := clred;
    {flag=0}
  end;
end;

procedure Tfrmmsgsend.N5Click(Sender: TObject);
begin
  lview.Items.Clear;
end;

procedure Tfrmmsgsend.N4Click(Sender: TObject);
begin
  lview.DeleteSelected;
end;

procedure Tfrmmsgsend.lbhelpMouseEnter(Sender: TObject);
begin
  lbhelp.Font.Color:=clred;
end;

procedure Tfrmmsgsend.lbhelpMouseLeave(Sender: TObject);
begin
  if lbhelp.Font.Color=clred then
  lbhelp.Font.Color:=Label1.Font.Color;
end;

procedure Tfrmmsgsend.lbhelpClick(Sender: TObject);
begin
  ShellExecute(handle, 'open',pchar(ExtractFilePath(application.ExeName)+'MESSAGE帮助.hlp'),nil,nil, SW_SHOWNORMAL);
  //winexec(pchar(ExtractFilePath(application.ExeName)+'MESSAGE帮助.hlp'),handle);
end;

procedure Tfrmmsgsend.mmsgmemoKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if shift = [ssCtrl] then
  begin
    if key=13 then
    begin
      speedbutton1.Click;
    end;
  end;
end;

end.