📄 un_chart.pas

📁 局域网的一个聊天程序
💻 PAS
📖 第 1 页 / 共 3 页
字号:
       if pc_list.Items[i-1].Selected then
        begin
        pc_list.Items[i-1].subitems.Strings[3]:=inttostr(strtoint(pc_list.Items[i-1].subitems.Strings[3])+1);
        msg:=msg+(form_main.get_user_infostring(pc_list.Items[i-1].caption,pc_list.Items[i-1].subitems.strings[0],pc_list.Items[i-1].subitems.strings[1],pc_list.Items[i-1].subitems.strings[2]));
         t:=TsendfileThread.Create(true);
         t.server:=pc_list.Items[i-1].SubItems.strings[1];
         t.ip:=pc_list.Items[i-1].SubItems.strings[2];
         t.filen:=Tstringlist.Create;
         t.filen.Text:=form_main.op_file.Files.Text;
         t.FreeOnTerminate:=true;
         t.Resume;
        end;
     end;
    msg:=msg+(#13#10+'文件：'+#13#10);
    for i:=1 to form_main.op_file.Files.Count do
     begin
      msg:=msg+('[url='+extractfiledir(form_main.op_file.Files.Strings[i-1])+']'+form_main.op_file.Files.Strings[i-1]+'[/url]'+#13#10);
     end;
    msg:=msg+(#13#10);
    form_main.writemsg(msg);
  end;
end
else
messagebox(handle,'请选择要发送的用户！','错误',mb_ok+mb_iconerror);
end;

{ TsendfileThread }

procedure TsendfileThread.Execute;
var
udpc:Tidudpclient;
s:Tstrings;
rs:string;
i:integer;
msg:string;
begin
  inherited;
  s:=Tstringlist.Create;
  udpc:=Tidudpclient.Create(nil);
  try
  udpc.Host:=ip;
  udpc.Port:=3001;
  udpc.ReceiveTimeout:=10000;
  s.Text:='getfile'+#13#10+httpencode(filen.Text);
  udpc.Send(s.Text);
  rs:=udpc.ReceiveString;
  if rs='' then
   begin
    msg:='[color=#ff0000]无法发送文件至 '+ip+' '+datetimetostr(now)+'[/color]'+#13#10;
    msg:=msg+'文件：'+#13#10;
    for i:=1 to filen.Count do
     begin
      msg:=msg+'[url='+extractfiledir(filen.Strings[i-1])+']'+filen.Strings[i-1]+'[/url]'+#13#10;
     end;
    msg:=msg+#13#10;
    form_main.writemsg(msg);
    application.ProcessMessages;
   end;
  except
  end; 
  udpc.Destroy;
  s.Destroy;
  filen.Destroy;
end;

procedure Tform_chat.ac_clearmsgExecute(Sender: TObject);
begin
 if messagebox(handle,'确定要清空聊天历史吗？','清空聊天历史',mb_yesno+MB_ICONQUESTION)=mryes then
  begin
   clearchatall;
   mm_msgall.Clear;
  end;
end;

procedure Tform_chat.ac_userlistExecute(Sender: TObject);
begin
 panel3.Visible:=not panel3.Visible;
 splitter2.Visible:=not splitter2.Visible;
 splitter2.Left:=panel3.Left;
end;

procedure Tform_chat.ac_scrmsgExecute(Sender: TObject);
begin
 ;
end;

procedure Tform_chat.ac_savemsgExecute(Sender: TObject);
var
D: IHTMLDocument2;
OleI: olevariant;
OleWin: olevariant;
aWindow: IHTMLWindow2;
f:Tstrings;
Ts:string;
begin
 ts:=formatdatetime('yyyy年mm月dd日 hh时mm分ss秒',now);
 form_main.sv_file.Filter:='html|*.htm;*.html';
 form_main.sv_file.Title:='聊天记录保存';
 form_main.sv_file.FileName:=form_main.sv_file.InitialDir+'快讯聊天记录 '+ts+'.htm';


  if form_main.sv_file.Execute then
   begin
    f:=Tstringlist.Create;
    try
     d:=msgall.document as IHTMLDocument2;
     OleI:=0;
     OleWin:=D.Frames.Item(OleI);
     IUnknown(OleWin).QueryInterface(IID_IHTMLWindow2, aWindow);
     d:=awindow.document;
     f.Add('<html>');
     f.Add('<head>');
     f.Add('<title>');
     f.Add('快讯聊天记录 '+ts);
     f.Add('</title>');
     f.Add('</head>');
     f.Add(d.body.outerHTML);
     f.Add('</html>');
     f.SaveToFile(form_main.sv_file.FileName);  
    except
    end;
    f.Free;
    d:=nil;
   end;
end;

procedure Tform_chat.ac_userExecute(Sender: TObject);
var
s:string;
begin
 s:=form_chat.inputval('用户','请输入用户名称',form_main.user_name);
 if s<>'' then
  begin
   form_main.user_name:=s;
   setstatusbar;
  end;
end;

procedure Tform_chat.ac_partExecute(Sender: TObject);
var
s:string;
begin
 s:=form_chat.inputval('聊天组','请输入聊天组名称',form_main.user_part);
 if s<>'' then
  begin
   form_main.user_part:=s;
   setstatusbar;
  end; 
end;

procedure Tform_chat.setstatusbar;
begin
 form_chat.StatusBar1.Panels[0].Text:='用户：'+form_main.user_name;
 form_chat.StatusBar1.Panels[1].Text:='聊天组：'+form_main.user_part;
 form_chat.StatusBar1.Panels[2].Text:='计算机：'+form_main.pc_name;
end;

procedure Tform_chat.checkmsg;
begin
   form_main.tim_flasicon.Enabled:=false;
   form_main.RzTrayIcon1.IconIndex:=0;
end;

function CustomSortProc(Item1, Item2: TListItem; ParamSort: integer): integer; stdcall;
var
i:integer;
begin
result:=0;
  if abs(ParamSort)-1=0 then
   Result := ParamSort * CompareText(Item1.Caption,Item2.Caption)
  else
   begin
    i:=abs(ParamSort)-2;
    //showmessage(inttostr(i));
    result:= (ParamSort div abs(ParamSort) ) * CompareText(Item1.SubItems.Strings[i],Item2.SubItems.Strings[i]);
   end;
end;


procedure Tform_chat.pc_listColumnClick(Sender: TObject;
  Column: TListColumn);
begin
  if column.Tag=0 then
   column.Tag:=1;
  column.Tag:=column.Tag * -1;
  pc_list.CustomSort(@CustomSortProc, (Column.Index+1) * column.Tag);
end;

function Tform_chat.adduser(ip: string): TListItem;
var
i:integer;
got:boolean;
r:TListitem;
begin
   i:=0;
   while getpcinfobusy and (i<100) do
    begin
     sleep(10);
     i:=i+1;
    end;
   getpcinfobusy:=true;
got:=false;
 for i:=0 to pc_list.Items.Count-1 do
  begin
   if pc_list.Items[i].SubItems.Strings[2]=ip then
    begin
     result:=pc_list.Items[i];
     got:=true;
     break;
    end;
  end;
 if not got then
  begin
   r:=pc_list.Items.Add;
   with r do
    begin
     checked:=true;
     subitems.Add('');
     subitems.Add('');
     subitems.Add(ip);
     subitems.Add('0');
     subitems.Add('0');
     imageindex:=3;
    end;
   result:=r; 
  end;
  getpcinfobusy:=false;
end;

function Tform_chat.getpcinfo(ip: string): boolean;
var
udpc:TIdUDPClient;
s:Tstrings;
begin
s:=Tstringlist.Create;
udpc:=TIdUDPClient.Create(nil);
try
result:=false;
udpc.ReceiveTimeout:=form_main.conntimeout;
udpc.Host:=ip;
udpc.Port:=3001;
udpc.Send('getpcinfo');
 s.Text:=udpc.ReceiveString;
if s.Text<>'' then
 begin
 if s.Strings[0]=ip then
  begin
   with form_chat.adduser(ip) do
    begin
     caption:=s.Strings[1];
     subitems.Strings[0]:=s.Strings[2];
     subitems.Strings[1]:=s.Strings[3];
     if s.Strings[4]='在线' then
      imageindex:=2;
    end;
   result:=true;
  end; 
 end;
except

end;
udpc.Destroy;
s.Destroy;
end;

procedure Tform_chat.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  form_chat.WindowState:=wsMinimized;
end;

{ TgetpcThread }

procedure TgetpcThread.Execute;
var
i:integer;
begin
  inherited;
  for i:=1 to iplist.count do
   begin
    if form_chat.getpcinfo(iplist.Strings[i-1]) and reqadd then
     form_chat.reqaddpc(iplist.Strings[i-1],true);
   end;
  iplist.Free;
end;

procedure Tform_chat.ac_refreshuserlistExecute(Sender: TObject);
var
t:TreqaddpcallThread;
begin
   t:=TreqaddpcallThread.Create(false);
end;

procedure Tform_chat.ac_sendmsgExecute(Sender: TObject);
var
t:TsendmsgThread;
i:integer;
msg:string;
begin
ac_sendmsg.Enabled:=false;
 if (mm_msginput.Text=#13#10) or (mm_msginput.Text='') then
  begin
   messagebox(handle,'请不要发送空信息！','错误',mb_ok+mb_iconerror);
  end
 else if pc_list.SelCount=0 then
  begin
   messagebox(handle,'请选择要发送的用户！','错误',mb_ok+mb_iconerror);
  end
 else
  begin
   msg:=msg+('[color=#00ffff]'+formatdatetime('yy-mm-dd hh:mm:ss',now)+' 发送消息 [/color]');
   for i:=1 to pc_list.Items.Count do
    begin
      if pc_list.Items[i-1].Selected then
       begin
        pc_list.Items[i-1].subitems.Strings[3]:=inttostr(strtoint(pc_list.Items[i-1].subitems.Strings[3])+1);       
        msg:=msg+(form_main.get_user_infostring(pc_list.Items[i-1].caption,pc_list.Items[i-1].subitems.strings[0],pc_list.Items[i-1].subitems.strings[1],pc_list.Items[i-1].subitems.strings[2]));
        t:=TsendmsgThread.Create(true);
        t.threadmsg:=mm_msginput.Lines.Text;
        t.server:=pc_list.Items[i-1].Caption;
        //t.ip:='192.168.0.255';
        t.ip:=pc_list.Items[i-1].SubItems.strings[2];
        t.FreeOnTerminate:=true;
        t.Resume;
        //t.Execute;
        application.ProcessMessages;
       end;
    end;
    msg:=msg+(#13#10+mm_msginput.Lines.Text+#13#10+#13#10);
    form_main.writemsg(msg);
    mm_msginput.Clear;
    lb_sizecnt.Caption:=inttostr(length(mm_msginput.Text))+'/'+inttostr(mm_msginput.maxlength);
  end;
ac_sendmsg.Enabled:=true;

end;

function Tform_chat.reqaddpc(ip: string;reqadd:bool): boolean;
var
udpc:TIdUdpclient;
begin
udpc:=TIdUdpclient.Create(nil);
udpc.Host:=ip;
udpc.Port:=3001;
 try
  udpc.ReceiveTimeout:=form_main.conntimeout;
  if reqadd then
   udpc.Send('adduser_login')
  else
   udpc.Send('adduser');
 result:=true;
 except
 result:=false;
 end;
udpc.Destroy;
end;

procedure Tform_chat.deleteuser(ip: string);
var
i:integer;
begin
 for i:=1 to pc_list.Items.Count do
  begin
   if (pc_list.Items[i-1].subitems.strings[2]=ip) then
    begin
     pc_list.Items[i-1].Delete;
     break;
    end;
  end;
end;

function Tform_chat.reqdeletepc(ip: string): boolean;
var
udpc:TIdUdpclient;
begin
udpc:=TIdUdpclient.Create(nil);
udpc.Host:=ip;
udpc.Port:=3001;
 try
  udpc.ReceiveTimeout:=form_main.conntimeout;
  udpc.Send('deleteuser');
 result:=true;
 except
 result:=false;
 end;
udpc.Destroy;
end;

function Tform_chat.finduserbyip(ip: string;addnotexists:bool): TListitem;
var
i:integer;
l:TListitem;
begin
l:=nil;
 for i:=1 to pc_list.Items.Count do
  begin
   if ip=pc_list.Items[i-1].SubItems[2] then
    begin
     l:=pc_list.Items[i-1];
     break;
    end;
  end;
  if (l=nil) and addnotexists then
   begin
    if form_chat.getpcinfo(ip) then
    l:=finduserbyip(ip,false);
   end;
  result:=l;
end;

procedure Tform_chat.FormShow(Sender: TObject);
begin
  showwindow(application.handle,sw_hide);
end;

procedure Tform_chat.ac_selectothersExecute(Sender: TObject);
var
i:integer;
begin
💿 文件大小 453 K
👤 上传用户 SLing2008
📂 所属分类 Internet/网络编程
🏷️ 相关标签

#局域网 #程序
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -