un_chart.pas

局域网的一个聊天程序

unit Un_chart;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ScktComp, IdBaseComponent,
  IdComponent, IdTCPServer, IdTCPConnection, IdTCPClient, IdThreadMgr,
  IdThreadMgrDefault, Sockets, Wave, DXSounds, MPlayer, OleCtrls, SHDocVw,mshtml,activex,HTTPApp,
  IdHTTP, Grids, ValEdit, Buttons, ToolWin, ActnMan, ActnCtrls, ActnList,
  XPStyleActnCtrls, ActnMenus, ImgList, Menus, IdUDPBase, IdUDPClient;


type  

TsendmsgThread = class(TThread)
  private
  public
   threadmsg:string;
   server:string;
   ip:string;
   procedure Execute; override;
  end;

TsendmsgoffThread = class(TThread)
  private
  public
   threadmsg:string;
   server:string;
   ip:string;
   procedure Execute; override;
  end;

TsendfileThread = class(TThread)
  private
  public
   server:string;
   ip:string;
   filen:Tstrings;
   procedure Execute; override;
  end;

TgetpcThread = class(TThread)
  private
  public
   iplist:Tstrings;
   reqadd:boolean;
   procedure Execute; override;
  end;

TreqaddpcThread = class(TThread)
  private
   ip:string;
  public
   procedure Execute; override;
  end;

TreqdeletepcThread = class(TThread)
  private
   ip:string;
  public
   procedure Execute; override;
  end;

TreqaddpcallThread = class(TThread)
  private
  public
   procedure Execute; override;
  end;

TreqsetstatusThread = class(TThread)
  private
   ip:string;
   cmd:string;
  public
   procedure Execute; override;
  end;

TsetstatusThread = class(TThread)
  private
  public
   procedure Execute; override;
  end;


  Tform_chat = class(TForm)
    Panel1: TPanel;
    mm_msginput: TMemo;
    Panel2: TPanel;
    Button1: TButton;
    Splitter1: TSplitter;
    Splitter2: TSplitter;
    ActionManager1: TActionManager;
    ac_sendlocalimg: TAction;
    ac_sendnetimg: TAction;
    as_sendlocalfile: TAction;
    ac_userlist: TAction;
    ControlBar1: TControlBar;
    ActionMainMenuBar1: TActionMainMenuBar;
    ac_clearmsg: TAction;
    ac_savemsg: TAction;
    ac_scrmsg: TAction;
    ac_user: TAction;
    ac_part: TAction;
    StatusBar1: TStatusBar;
    panel3: TPanel;
    pc_list: TListView;
    pm_pclist: TPopupMenu;
    ac_refreshuserlist: TAction;
    N2: TMenuItem;
    ac_sendmsg: TAction;
    ac_selectothers: TAction;
    N3: TMenuItem;
    ac_disableothers: TAction;
    N1: TMenuItem;
    ac_selectall: TAction;
    ac_disableall: TAction;
    N4: TMenuItem;
    N5: TMenuItem;
    ac_setstatus: TAction;
    ac_setoffresponse: TAction;
    ac_sendlocalflash: TAction;
    ac_sendnetflash: TAction;
    ac_sendlocalmp: TAction;
    ac_sendnetmp: TAction;
    ac_sendlocalrm: TAction;
    ac_sendnetrm: TAction;
    Panel4: TPanel;
    msgall: TWebBrowser;
    mm_msgall: TMemo;
    Splitter3: TSplitter;
    ac_viewtextmsg: TAction;
    ac_savemsgtext: TAction;
    ac_cleanuserlist: TAction;
    N6: TMenuItem;
    N7: TMenuItem;
    lb: TLabel;
    lb_sizecnt: TLabel;
    procedure mm_msginputKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure mm_msginputEnter(Sender: TObject);
    procedure mm_msginputKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure ac_sendlocalimgExecute(Sender: TObject);
    procedure ac_sendnetimgExecute(Sender: TObject);
    procedure as_sendlocalfileExecute(Sender: TObject);
    procedure ac_clearmsgExecute(Sender: TObject);
    procedure ac_userlistExecute(Sender: TObject);
    procedure ac_scrmsgExecute(Sender: TObject);
    procedure ac_savemsgExecute(Sender: TObject);
    procedure ac_userExecute(Sender: TObject);
    procedure ac_partExecute(Sender: TObject);
    procedure pc_listColumnClick(Sender: TObject; Column: TListColumn);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ac_refreshuserlistExecute(Sender: TObject);
    procedure ac_sendmsgExecute(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ac_selectothersExecute(Sender: TObject);
    procedure ac_disableothersExecute(Sender: TObject);
    procedure ac_selectallExecute(Sender: TObject);
    procedure ac_disableallExecute(Sender: TObject);
    procedure mm_msginputChange(Sender: TObject);
    procedure ac_setstatusExecute(Sender: TObject);
    procedure ac_setoffresponseExecute(Sender: TObject);
    procedure ac_sendlocalflashExecute(Sender: TObject);
    procedure ac_sendnetflashExecute(Sender: TObject);
    procedure ac_sendlocalmpExecute(Sender: TObject);
    procedure ac_sendnetmpExecute(Sender: TObject);
    procedure ac_sendlocalrmExecute(Sender: TObject);
    procedure ac_sendnetrmExecute(Sender: TObject);
    procedure ac_viewtextmsgExecute(Sender: TObject);
    procedure ac_savemsgtextExecute(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure ac_cleanuserlistExecute(Sender: TObject);
    procedure pc_listDeletion(Sender: TObject; Item: TListItem);
    procedure pc_listInsert(Sender: TObject; Item: TListItem);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    getpcinfobusy:boolean;
    reqaddpccnt:integer;                  //请求添加计算机的线程数
    reqdeletepccnt:integer;               //请求删除计算机的线程数
    reqsetstatuscnt:integer;              //请求修改用户状态的线程数
    procedure writemsgall(msg:string);   //写聊天消息到聊天栏
    procedure clearchatall;              //清空聊天栏
    procedure showwelcom;                 //显示欢迎信息
    function inputval(title:String;info:string;defaultval:string):string; //输入一个值
    procedure setstatusbar();                                              //写状态栏
    procedure checkmsg();    //接受消息后执行的过程
    function adduser(ip:string):TListItem;   //添加一个用户到用户列表
    function getpcinfo(ip:string):boolean;   //获得计算机信息
    function reqaddpc(ip:string;reqadd:bool):boolean;    //请求一台计算机添加自己
    function reqsetstatus(ip:string;cmd:string):boolean;                        //广播自己的状态
    function reqdeletepc(ip:string):boolean; //请求一台计算机删除自己
    procedure reqdeletepcall;                //广播删除自己的请求
    procedure deleteuser(ip:string);         //从用户列表中删除一个用户
    function finduserbyip(ip:string;addnotexists:bool):TListitem;    //根据ip地址从列表中找到一个用户
    function pcexists(ip:string):boolean;           //判断一台计算机是否在列表中存在
    function getubb(ubb:string;pa:string;s:string):string;  //根据ubb标签的信息返回对应的完整代码
    function getlocalfileurl(filename:string;ctfilename:bool):string;   //返回本地文件在网络上的访问地址
  end;


var
  form_chat: Tform_chat;

implementation

uses  Un_main, Un_input;

{$R *.dfm}

procedure Tform_chat.mm_msginputKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if (key=13) and (ssCtrl in shift) then
  begin
   mm_msginput.Text:=copy(mm_msginput.Text,0,length(mm_msginput.Text)-2);
   ac_sendmsg.Execute;
  end;
end;

procedure Tform_chat.mm_msginputEnter(Sender: TObject);
begin
checkmsg;
lb_sizecnt.Caption:=inttostr(length((sender as Tmemo).Text))+'/'+inttostr((sender as Tmemo).maxlength);
end;

procedure Tform_chat.mm_msginputKeyPress(Sender: TObject; var Key: Char);
begin
checkmsg;
end;

procedure Tform_chat.writemsgall(msg: string);
var
D: IHTMLDocument2;
OleI: olevariant;
OleWin: olevariant;
aWindow: IHTMLWindow2;
Form :  IHTMLFormElement;
begin
try
 d:=msgall.document as IHTMLDocument2;
 //d:=d.frames.item('0') as HTMLFrameElement);
 OleI:=1;
 OleWin:=D.Frames.Item(OleI);
 IUnknown(OleWin).QueryInterface(IID_IHTMLWindow2, aWindow);
 d:=awindow.document;
 //showmessage(awindow.document.body.innerHTML);
 Form := awindow.document.Forms.item('f',0) as IHTMLFormElement;
 (form.item('msg',0) as IHTMLElement).setAttribute('value',msg,0);
 (form.item('sc',0) as IHTMLElement).setAttribute('checked',ac_scrmsg.Checked,0);
 (form.item('b',0) as IHTMLElement).click;
 d:=nil;
except
 messagebox(handle,'无法正常写入消息！请检查Internet Explorer是否脱机工作！','错误',mb_ok+mb_iconerror);
end;
end;



procedure Tform_chat.FormCreate(Sender: TObject);
begin
 msgall.Navigate('http://127.0.0.1:3000/chat_main');
 setstatusbar;

 with form_chat.adduser(form_main.IdIP.LocalIP) do    //添加自己到用户列表
  begin
   caption:=form_main.user_name;
   subitems.Strings[0]:=form_main.user_part;
   subitems.Strings[1]:=form_main.pc_name;
  end;
  ac_refreshuserlist.Execute;
  form_main.RzTrayIcon1.Enabled:=true;
end;

procedure Tform_chat.clearchatall;
var
D: IHTMLDocument2;
OleI: olevariant;
OleWin: olevariant;
aWindow: IHTMLWindow2;
Form :  IHTMLFormElement;
begin
try
 d:=msgall.document as IHTMLDocument2;
 //d:=d.frames.item('0') as HTMLFrameElement);
 OleI:=1;
 OleWin:=D.Frames.Item(OleI);
 IUnknown(OleWin).QueryInterface(IID_IHTMLWindow2, aWindow);
 d:=awindow.document;
 //showmessage(awindow.document.body.innerHTML);
 Form := awindow.document.Forms.item('f',0) as IHTMLFormElement;
 (form.item('c',0) as IHTMLElement).click;
 d:=nil;
except
end; 
end;




{ TsendmsgThread }

procedure TsendmsgThread.Execute;
var
udpc:Tidudpclient;
s:Tstrings;
rs:string;
msg:string;
begin
  inherited;
  s:=Tstringlist.Create;
  udpc:=Tidudpclient.Create(nil);
  try
  udpc.Host:=ip;
  udpc.Port:=3001;
  udpc.ReceiveTimeout:=10000;
  s.Text:='chat'+#13#10+httpencode(Threadmsg);
  udpc.Send(s.Text);
  rs:=udpc.ReceiveString;
  if rs='' then
   begin
    msg:='[color=#ff0000]无法发送消息至 '+ip+' '+datetimetostr(now)+'[/color]'+#13#10;
    msg:=msg+'消息内容：'+#13#10;
    msg:=msg+Threadmsg+#13#10+#13#10;
    form_main.writemsg(msg);
    application.ProcessMessages;
   end;
  except
  end; 
  udpc.Destroy;;
  s.Destroy;
end;

procedure Tform_chat.showwelcom;
var
D: IHTMLDocument2;
OleI: olevariant;
OleWin: olevariant;
aWindow: IHTMLWindow2;
Form :  IHTMLFormElement;
begin
 d:=msgall.document as IHTMLDocument2;
 //d:=d.frames.item('0') as HTMLFrameElement);
 OleI:=1;
 OleWin:=D.Frames.Item(OleI);
 IUnknown(OleWin).QueryInterface(IID_IHTMLWindow2, aWindow);
 d:=awindow.document;
 //showmessage(awindow.document.body.innerHTML);
 Form := awindow.document.Forms.item('f',0) as IHTMLFormElement;
 (form.item('s',0) as IHTMLElement).click;
 d:=nil;
end;

procedure Tform_chat.ac_sendlocalimgExecute(Sender: TObject);
var
i:integer;
begin
form_main.op_file.Filter:='jpeg|*.jpg;*.jpeg|bmp|*.bmp|gif|*.gif|所有文件|*.*';
form_main.op_file.Title:='请选择要张贴的图片';
form_main.op_file.Options:=[ofHideReadOnly,ofNoChangeDir,ofAllowMultiSelect,ofEnableSizing];
//form_main.op_file.Options:=[ofHideReadOnly,ofNoChangeDir,ofEnableSizing];
 if form_main.op_file.Execute then
  begin
  for i:=1 to form_main.op_file.Files.Count do
   begin
    mm_msginput.Text:=mm_msginput.Text+form_chat.getubb('img','',getlocalfileurl(form_main.op_file.Files.Strings[i-1],true));
    form_main.addto_alwdownfilelist(form_main.op_file.Files.Strings[i-1]);
   end
  end;
end;

function Tform_chat.inputval(title, info,defaultval: string): string;
var
form:Tform_input;
begin
 form:=Tform_input.Create(nil);
 form.Caption:=title;
 form.lb_inf.Caption:=info;
 form.ed_val.Text:=defaultval;
 if (form.ShowModal=mrOk) then
  result:=form.ed_val.Text
 else
  result:='';
 form.Free;
end;

procedure Tform_chat.ac_sendnetimgExecute(Sender: TObject);
var
s:string;
begin
  s:=inputval('选择网络图片','请输入网络图片的位置','http://');
  if s<>'' then
   mm_msginput.Text:=mm_msginput.Text+form_chat.getubb('img','',s);
end;

procedure Tform_chat.as_sendlocalfileExecute(Sender: TObject);
var
t:TsendfileThread;
i:integer;
msg:string;
begin
if pc_list.SelCount>0 then
 begin
  form_main.op_file.Filter:='所有文件|*.*';
  form_main.op_file.Title:='请选择要发送的文件';
  form_main.op_file.Options:=[ofHideReadOnly,ofNoChangeDir,ofAllowMultiSelect,ofEnableSizing];
   if form_main.op_file.Execute then
    begin
     for i:=1 to form_main.op_file.Files.Count do
      begin
       form_main.addto_alwdownfilelist(form_main.op_file.Files[i-1]);
      end;
     msg:=('[color=#ff00ff]'+formatdatetime('yy-mm-dd hh:mm:ss',now)+' 发送文件 [/color]');
     for i:=1 to pc_list.Items.Count do
      begin