T
tl_lyq
Unregistered / Unconfirmed
GUEST, unregistred user!
客户端
运行一段时间退出时报错:
1.Exception Eoserror in module tl-netchat.exe at 0000dc02 A call to OS function failed.
2.来信息时窗体弹出后,无法响应鼠标.
3.有时退出报内存非法操作,
program Project1;
uses
Forms,windows,SysUtils,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.res}
function StartExe(S:string):boolean;
var aHandle: tHandle;
P:array[0..79]of char;
begin
result:=true;
strpcopy(p,s);
aHandle:=FindWindow(pchar('tapplication'),p);
if ahandle<>0 then
begin
result:=false;
end;
end;
begin
if startExe('信息交流程序') then
begin
Application.ShowMainForm :=false;
Application.Initialize;
Application.Title := '信息交流程序';
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.
unit Unit1;
interface
uses
Windows,messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
IdUDPServer, ExtCtrls, ImgList, Menus, IdStack, antTaskbarIcon, ComCtrls, StdCtrls, Buttons,
IdAntiFreezeBase, IdAntiFreeze, IdUDPBase, IdComponent,MMsystem,
IdBaseComponent,IdSocketHandle,IdWinsock, Winsock,IniFiles,ShellAPI,
PageList, Dialogs;
type
TForm1 = class(TForm)
Panel1: TPanel;
Bexit: TSpeedButton;
Bsave: TSpeedButton;
Brefresh: TSpeedButton;
Bsetup: TSpeedButton;
Babout: TSpeedButton;
Bhide: TSpeedButton;
Panel6: TPanel;
Panel3: TPanel;
Splitter1: TSplitter;
richedit1: TMemo;
richedit2: TMemo;
Panel4: TPanel;
Panel5: TPanel;
Bselectno: TSpeedButton;
Bselectall: TSpeedButton;
Save1: TSaveDialog;
Taba1: TantTaskbarIcon;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N5: TMenuItem;
N3: TMenuItem;
N6: TMenuItem;
N4: TMenuItem;
imlstIcons: TImageList;
Timer1: TTimer;
S1: TIdUDPServer;
IdAntiFreeze1: TIdAntiFreeze;
Panel2: TPanel;
PageList1: TPageList;
List1: TListView;
List2: TListView;
List3: TListView;
ImageList1: TImageList;
TimerMessBeep: TTimer;
Bhistory: TSpeedButton;
Panhis: TPanel;
Memo1: TMemo;
Panel7: TPanel;
SpeedButton2: TSpeedButton;
SpeedButton1: TSpeedButton;
SpeedButton4: TSpeedButton;
SpeedButton3: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure wmQUERYENDSESSION(var msg:tWMQUERYENDSESSION);message WM_QUERYENDSESSION;
procedure WMSYSCOMMAND(var msg: TWMSYSCOMMAND); message WM_SYSCOMMAND;
procedure FrmInits();
procedure FrmClose();
procedure FrmActive();
procedure FrmHide();
procedure RegInfo();
function GetLocalIP:String;
function Getcomputer:String;
procedure serverbind();
procedure N4Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure SendOnline(const IP:String);
procedure SendLogin(const IP:String);
procedure SendLogout(const IP:String);
procedure sendChangenick(const IP,Newnick:String);
procedure SendChangeGroup(const IP,NewGroupIndex:String);
procedure S1UDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
procedure BselectallClick(Sender: TObject);
procedure BselectnoClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure BexitClick(Sender: TObject);
procedure BsaveClick(Sender: TObject);
procedure BrefreshClick(Sender: TObject);
procedure BhideClick(Sender: TObject);
procedure BaboutClick(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure BsetupClick(Sender: TObject);
procedure richedit1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure MessageAutoScroll();
procedure List1InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
procedure List2InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
procedure GetBroadIP();
procedure richedit2KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure richedit2KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure List3InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
procedure TimerMessBeepTimer(Sender: TObject);
procedure SysAutoRead();
procedure SysAutoWrite(S1:string);
procedure BhistoryClick(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
procedure SpeedButton3Click(Sender: TObject);
procedure SpeedButton4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
TheTitle='信息交流程序';
HeaderLen =6;
IPLen =15;
PortLen =5;
ServerPort =5818;
OverTime =30;//秒
Checktime =10000;//毫秒
LocalNetHead ='192.168';
PROXYIP ='10.0.0.1';
LOCALBROADCAST ='255.255.255.255';
TLServerIP ='192.168.0.1';
Error='程序运行错误：';
var
Form1: TForm1;
sBuffer: PChar;
sSize: Cardinal;
LocalIP,LocalNick,ComputerName,BroardIP,InGroup,InGroupIndex:string;
IsInternetIP,Autosave,SendNw:boolean;
myMsg:tmessage;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.WMSYSCOMMAND(var msg: TWMSYSCOMMAND);
begin
if Msg.CmdType=SC_MINIMIZE then
begin
Frmhide();
end
else
inherited;
end;
procedure Tform1.wmQUERYENDSESSION(var msg:TWMQUERYENDSESSION);
begin
myMsg.Result :=1;
Msg.Result := 1;
inherited;
end;
procedure TForm1.GetBroadIP();
begin
if copy(LocalIP,0,7)=LocalNetHead then
begin
IsInternetIP:=false;
BroardIP:=LOCALBROADCAST;
end
else
begin
IsInternetIP:=true;
BroardIP:=PROXYIP;
end;
end;
procedure TForm1.FrmInits();
begin
RegInfo();
self.Caption :=TheTitle;
application.Title :=TheTitle;
if AutoSave then
try richedit1.Lines.LoadFromFile(ExtractFilePath(Application.ExeName)+'history.txt');except end;
GetBroadIP();
end;
procedure TForm1.RegInfo();
var myinifile:Tinifile;
filename:string;
begin
ComputerName:=Getcomputer();
LocalIP:=GetLocalIP();
filename:=ExtractFilePath(paramstr(0))+'myini.ini';
myinifile:=TInifile.Create(filename);
LocalNick:= myinifile.readstring('parameter','UserName',computername);
AutoSave:= myinifile.readbool('parameter','ExitAutoSave',False);
InGroup:=myinifile.readstring('parameter','Group','custom');
InGroupIndex:=myinifile.readstring('parameter','GroupIndex','1');
end;
procedure TForm1.FrmActive();
begin
ShowWindow(Application.Handle, SW_SHOW);
visible:=true;
Taba1.ImageIndex :=1;
SendMessage(richedit1.Handle,WM_VScroll,sb_Bottom,0);
self.Refresh;
end;
procedure TForm1.FrmHide();
begin
ShowWindow(Application.Handle, SW_HIDE);
Taba1.ImageIndex :=0;
PlaySound(nil,0,0);
Visible := False;
end;
procedure TForm1.FrmClose();
begin
if MessageBox(Handle, '关闭本软件后,您将无法接受来自其它用户从网络传来的信息,真的要关闭本软件吗', '系统提醒', MB_ICONQUESTION or MB_YESNO) = IDYES then
begin
SendLogout(BroardIP);
s1.Active :=false;
if AutoSave then
try richedit1.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'history.txt');except end;
application.Terminate;
exit;
end;
end;
procedure TForm1.serverbind();
begin
s1.Bindings[0].Port :=ServerPort;
s1.Binding;
timer1.Interval:=Checktime;
timer1.Enabled :=true;
end;
function Tform1.GetLocalIP:String;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I : Integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
try
Result:='';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^ <> nil do
begin
result:=StrPas(inet_ntoa(pptr^^));
Inc(I);
end;
finally
WSACleanup;
end;
end;
function Tform1.Getcomputer: string;
begin
sSize := 255;
GetMem(sBuffer, sSize + 1);
try
if GetComputerName(sBuffer, sSize) then
result:=sBuffer
finally
FreeMem(sBuffer);
end;
end;
procedure tform1.SendOnline(const IP:String);
var
Msg:String;
begin
Msg:=Trim(Format('%-15s%-6s%-5S%-255s',[LocalIP,'Online',inttostr(ServerPort),InGroupIndex+'!'+LocalNick+'@'+ComputerName]));
Try
s1.Send(IP,ServerPort,Msg);
Except
// richedit1.Lines.add(Error+'Send ''Online'' Error!!');
end;
end;
procedure tform1.SendLogin(const IP:String);
var
Msg:String;
begin
Msg:=Trim(Format('%-15s%-6s%-5S%-255s',[LocalIP,'Login',inttostr(ServerPOrt),InGroupIndex+'!'+LocalNick+'@'+ComputerName]));
Try
s1.Send(IP,ServerPort,Msg);
Except
richedit1.Lines.add(Error+'Send Login Error!!');
end;
end;
procedure tform1.SendChangenick(const IP,Newnick:String);
var
Msg:String;
begin
Msg:=Trim(Format('%-15s%-6s%-5S%-255s',[LocalIP,'Chnick',inttostr(serverPort),InGroupIndex+'!'+Newnick+'●'+LocalNick+'@'+ComputerName]));
Try
s1.Send(IP,ServerPort,Msg);
Except
richedit1.Lines.add(Error+'Send ''Chnick'' Error!!');
end;
end;
procedure tform1.SendChangeGroup(const IP,NewGroupIndex:String);
var
Msg:String;
begin
Msg:=Trim(Format('%-15s%-6s%-5S%-255s',[LocalIP,'ChGrp',inttostr(serverPort),NewGroupIndex+'!'+LocalNick+'@'+ComputerName]));
Try
s1.Send(IP,ServerPort,Msg);
Except
richedit1.Lines.add(Error+'Send ''ChGrp'' Error!!');
end;
end;
procedure tform1.SendLogout(const IP:String);
var
Msg:String;
begin
Msg:=Trim(Format('%-15s%-6s%-5S%-255s',[LocalIP,'Logout',inttostr(serverPort),InGroupIndex+'!'+LocalNick+'@'+ComputerName]));
Try
s1.Send(IP,ServerPort,Msg);
Except
richedit1.Lines.add(Error+'Send ''Logout'' Error!!');
end;
end;
procedure TForm1.N4Click(Sender: TObject);
begin
application.Terminate;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var i:integer;
d3:tdatetime;
h,m,s,d: Word;
begin
ComputerName:=Getcomputer();
LocalIP:=GetLocalIP();
GetBroadIP();
SendOnLine(BroardIP);
if list1.Items.Count > 0 then
for i:=list1.Items.Count-1 downto 0 do
begin
try
d3:=now-strtodatetime(list1.Items.SubItems[3]);
decodetime(d3,h,m,s,d);
if h*3600+m*60+s > OverTime then
list1.Items.Delete;
except end;
end;
if list2.Items.Count > 0 then
for i:=list2.Items.Count-1 downto 0 do
begin
try
d3:=now-strtodatetime(list2.Items.SubItems[3]);
decodetime(d3,h,m,s,d);
if h*3600+m*60+s > OverTime then
list2.Items.Delete;
except end;
end;
if list3.Items.Count > 0 then
for i:=list3.Items.Count-1 downto 0 do
begin
try
d3:=now-strtodatetime(list3.Items.SubItems[3]);
decodetime(d3,h,m,s,d);
if h*3600+m*60+s > OverTime then
list3.Items.Delete;
except end;
end;
end;
procedure TForm1.MessageAutoScroll();
begin
SendMessage(richedit1.Handle,WM_VScroll,sb_Bottom,0);
end;
procedure TForm1.S1UDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
var
Header,TrueFromIP,Trueport,Msg:String;
Item1 :TListItem;
RemoteNick,ReceIP,REceNick:string;
Newnick,Oldnick,GroupIndex:string;
DataStringStream: TStringStream;
begin
DataStringStream := TStringStream.Create('');
try
try
DataStringStream.CopyFrom(AData, AData.Size);
Msg:=DataStringStream.DataString;
TrueFromIP:=Trim(Copy(Msg,1,IPLen));
Header:=Trim(Copy(Msg,IPLen+1,HeaderLen));
Trueport:=Trim(Copy(Msg,IPLen+HeaderLen+1,Portlen));
Msg:=Trim(Copy(Msg,IPLen+HeaderLen+PortLen+1,Length(Msg)-IPLen-HeaderLen-PortLen));
Except
richedit1.Lines.add(Error+'Receive ''Udp Head'' Error!!');
end;
finally
DataStringStream.Free;
end;
if (Header='Login') and (truefromip <> Localip) then //SomeOne Login
begin
GroupIndex:=copy(msg,0,pos('!',msg)-1);
Msg:=copy(msg,pos('!',msg)+1,Length(Msg));
if GroupIndex='1' then
begin
Item1:=List1.FindCaption(0,Msg,False,true,true);
if item1=nil then
begin
SendOnLine(BroardIP);
with list1.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list1.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end
else if GroupIndex='2' then
begin
Item1:=List2.FindCaption(0,Msg,False,true,true);
if item1=nil then
begin
SendOnLine(BroardIP);
with list2.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list2.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end
else if GroupIndex='3' then
begin
Item1:=List3.FindCaption(0,Msg,False,true,true);
if item1=nil then
begin
SendOnLine(BroardIP);
with list3.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list3.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end;
end
else if (Header='Online') and (truefromip <> Localip) then//SomeOne SendOnline
begin
GroupIndex:=copy(msg,0,pos('!',msg)-1);
Msg:=copy(msg,pos('!',msg)+1,Length(Msg));
if GroupIndex='1' then
begin
Item1:=List1.FindCaption(0,Msg,False,True,true);
if item1=nil then
begin
SendOnLine(BRoardIP);
with list1.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list1.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end
else
if GroupIndex='2' then
begin
Item1:=List2.FindCaption(0,Msg,False,True,true);
if item1=nil then
begin
SendOnLine(BRoardIP);
with list2.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list2.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end
else if GroupIndex='3' then
begin
Item1:=List3.FindCaption(0,Msg,False,True,true);
if item1=nil then
begin
SendOnLine(BRoardIP);
with list3.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else
list3.Items[item1.Index].SubItems[3]:=datetimetostr(now());
end;
end
Else if (Header='Logout') and (truefromip <> Localip) then//SomeOne SendLogout
begin
GroupIndex:=copy(msg,0,pos('!',msg)-1);
Msg:=copy(msg,pos('!',msg)+1,Length(Msg));
if GroupIndex='1' then
begin
Item1:=List1.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list1.Items[item1.Index].Delete;
end
else if GroupIndex='2' then
begin
Item1:=List2.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list2.Items[item1.Index].Delete;
end
else if GroupIndex='3' then
begin
Item1:=List3.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list3.Items[item1.Index].Delete;
end;
end
else if (Header='Chat') and (truefromip <> Localip) then//SomeOne SendChat
begin
RemoteNick:=trim(copy(msg, 0,pos('●',msg)-1));
ReceIP:=copy(msg, pos('●',msg)+2,pos('★',msg)-4-pos('●',msg)+2);
REceNick:=copy(msg, pos('★',msg)+2,pos('☆',msg)-4-pos('★',msg)+2);
richedit1.Lines.Add(datetimetostr(now())+' '+RemoteNick+' 对 '+REceNick+' 说: '+#13#10+copy(msg,pos('ψ',msg)+2,length(msg)-2)+#13#10);
SysAutoWrite(datetimetostr(now())+' '+RemoteNick+' 对 '+REceNick+' 说: '+#13#10+copy(msg,pos('ψ',msg)+2,length(msg)-2)+#13#10);
MessageAutoScroll();
FrmActive();
if waveOutGetNumDevs > 0 then
PlaySound(pchar(ExtractFilePath(Application.EXEName)+'/Ding.wav'),0,snd_ASYNC or snd_loop)
else
TimerMessBeep.enabled:=true;
end
Else if (Header='Chnick') and (truefromip <> Localip) then //SomeOne Changenick
begin
GroupIndex:=copy(msg,0,pos('!',msg)-1);
Msg:=copy(msg,pos('!',msg)+1,Length(Msg));
Newnick:=trim(copy(msg, 0,pos('●',msg)-1));
Oldnick:=trim(copy(msg, pos('●',msg)+2,Length(Msg)));
if GroupIndex='1' then
begin
Item1:=List1.FindCaption(0,Oldnick,False,True,true);
if item1 <> nil then
list1.Items[item1.Index].Caption:=Newnick+'@'+copy(Oldnick,pos('@',Oldnick)+1,length(Oldnick));
end
else if GroupIndex='2' then
begin
Item1:=List2.FindCaption(0,Oldnick,False,True,true);
if item1 <> nil then
list2.Items[item1.Index].Caption:=Newnick+'@'+copy(Oldnick,pos('@',Oldnick)+1,length(Oldnick));
end
else if GroupIndex='3' then
begin
Item1:=List3.FindCaption(0,Oldnick,False,True,true);
if item1 <> nil then
list3.Items[item1.Index].Caption:=Newnick+'@'+copy(Oldnick,pos('@',Oldnick)+1,length(Oldnick));
end
end
Else if (Header='ChGrp') and (truefromip <> Localip) then //SomeOne Changenick
begin
GroupIndex:=copy(msg,0,pos('!',msg)-1);
Msg:=copy(msg,pos('!',msg)+1,Length(Msg));
Item1:=List1.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list1.Items[item1.Index].Delete;
Item1:=List2.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list2.Items[item1.Index].Delete;
Item1:=List3.FindCaption(0,Msg,False,True,true);
if item1 <> nil then
list3.Items[item1.Index].Delete;
if GroupIndex='1' then
begin
with list1.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else if GroupIndex='2' then
begin
with list2.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
else if GroupIndex='3' then
begin
with list3.Items.add do
begin
Caption:=msg;
SubItems.add(copy(msg,pos('@',msg)+1,length(msg)));
SubItems.add(Truefromip);
SubItems.add(Trueport);
SubItems.add(datetimetostr(now()));
end;
end
end;
end;
procedure TForm1.BselectallClick(Sender: TObject);
var i:integer;
begin
if Pagelist1.PageIndex=0 then
for i:=0 to list1.items.Count -1 do
list1.items.Checked:=true
else
if Pagelist1.PageIndex=1 then
for i:=0 to list2.items.Count -1 do
list2.items.Checked:=true
else
if Pagelist1.PageIndex=2 then
for i:=0 to list3.items.Count -1 do
list3.items.Checked:=true;
end;
procedure TForm1.BselectnoClick(Sender: TObject);
var i:integer;
begin
if PageList1.PageIndex=0 then
for i:=0 to list1.items.Count -1 do
list1.items.Checked:=False
else
if PageList1.PageIndex=1 then
for i:=0 to list2.items.Count -1 do
list2.items.Checked:=False
else
if PageList1.PageIndex=2 then
for i:=0 to list3.items.Count -1 do
list3.items.Checked:=False;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
application.HintPause :=0;
try
Taba1.visible:=true;
FrmInits();
serverbind();
except
MessageBox(Handle, '程序运行错误，可能原因：'+#13#10+#13#10+'1、未正确安装TCP/IP协议，请重新安装。'+#13#10+'2、本程序的另一副本已经运行，请重新启动您的微机。'+#13#10+'3、端口被占用，请退出其他程序。', '系统提醒', MB_ICONWARNING or MB_OK);
application.Terminate;
end;
sendLogin(BRoardIP);
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
If myMsg.Result=1 then
begin
SendLogout(BroardIP);
CanClose:=True;
if AutoSave then
richedit1.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'history.txt');
end
Else begin
CanClose:=False;
FrmHide();
end;
end;
procedure TForm1.BexitClick(Sender: TObject);
begin
FrmClose();
end;
procedure TForm1.BsaveClick(Sender: TObject);
begin
if save1.Execute then
richedit1.Lines.SaveToFile(save1.FileName );
end;
procedure TForm1.BrefreshClick(Sender: TObject);
begin
richedit1.Clear;
end;
procedure TForm1.BhideClick(Sender: TObject);
begin
FrmHide();
end;
procedure TForm1.BaboutClick(Sender: TObject);
begin
end;
procedure TForm1.N1Click(Sender: TObject);
begin
FrmActive();
end;
procedure TForm1.BsetupClick(Sender: TObject);
begin
form2:=Tform2.create(self);
form2.show;
end;
procedure TForm1.richedit1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
PlaySound(nil,0,0);
TimerMessBeep.enabled:=false;
end;
procedure TForm1.List1InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
begin
// try infotip:=infotip+' '+list1.ItemFocused.SubItems[4] ;except end;
end;
procedure TForm1.List2InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
begin
// try infotip:=infotip+' '+list2.ItemFocused.SubItems[4] ;except end;
end;
procedure TForm1.richedit2KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
Msg,IP,Nicks,ports:String;
i:integer;
SendWeb:boolean;
begin
if ([ssctrl]=shift) then
if key=VK_RETURN then
begin
if length(richEdit2.Text)<=7168 then
begin
if trim(richEdit2.Text)='' then
begin
MessageBox(0,'请先输入你想说的话！','干嘛呢，你？',MB_ICONINFORMATION+MB_OK);
richedit2.Clear;exit;
end
else
begin
for i:=0 to list1.items.Count -1 do
if list1.items.Checked then
begin
IP:=IP+list1.Items.SubItems[1] +',';
Nicks:=Nicks+copy(list1.Items.caption,0,pos('@',list1.Items.caption)-1)+',';
Ports:=Ports+list1.Items.SubItems[2] +',';
end;
for i:=0 to list2.items.Count -1 do
if list2.items.Checked then
begin
IP:=IP+list2.Items.SubItems[1] +',';
Nicks:=Nicks+copy(list2.Items.caption,0,pos('@',list2.Items.caption)-1)+',';
Ports:=Ports+list2.Items.SubItems[2] +',';
end;
for i:=0 to list3.items.Count -1 do
if list3.items.Checked then
begin
IP:=IP+list3.Items.SubItems[1] +',';
Nicks:=Nicks+copy(list3.Items.caption,0,pos('@',list3.Items.caption)-1)+',';
Ports:=Ports+list3.Items.SubItems[2] +',';
end;
IP:=copy(IP,0,length(IP)-1);
Nicks:=copy(Nicks,0,length(Nicks)-1);
Ports:=copy(Ports,0,length(Ports)-1);
if Trim(IP)='' then IP:=LocalIP;
if Trim(Nicks)='' then Nicks:=LocalNIck;
if Trim(Ports)='' then Ports:=inttostr(ServerPort);
Msg:=Format('%-15s%-6s%-5S%-255s',[LocalIP,'Chat','',localnick+'●'+IP+'★'+Nicks+'☆'+Ports+'ψ'+trim(richedit2.Lines.Text)+#13#10 ]);
if LocalNick=Nicks then Nicks:='自己'
else
begin
if not IsInternetip then
begin
for i:=0 to list1.items.Count -1 do
if list1.items.Checked=true then
if copy(List1.items.SubItems[1],0,7)=LocalNetHead then
s1.Send(List1.items.SubItems[1],ServerPort,Msg)
else SendWeb:=true;
for i:=0 to list2.items.Count -1 do
if list2.items.Checked=true then
if copy(List2.items.SubItems[1],0,7)=LocalNetHead then
s1.Send(List2.items.SubItems[1],ServerPort,Msg)
else SendWeb:=true;
for i:=0 to list3.items.Count -1 do
if list3.items.Checked=true then
if copy(List3.items.SubItems[1],0,7)=LocalNetHead then
s1.Send(List3.items.SubItems[1],ServerPort,Msg)
else SendWeb:=true;
if SendWeb then
begin
s1.Send(TlserverIP,ServerPort,Msg);
SendWeb:=false;
end;
end
else
s1.Send(BroardIP,ServerPort,Msg);
end;
SendNw:=true;
richedit1.Lines.Add(datetimetostr(now())+' '+LocalNick+' 对 '+Nicks+' 说 :'+#13#10+richedit2.Lines.text+#13#10);
SysAutoWrite(datetimetostr(now())+' '+LocalNick+' 对 '+Nicks+' 说 :'+#13#10+richedit2.Lines.text+#13#10);
MessageAutoScroll();
end;
richedit2.Clear;
end else MessageBox(0,'警告:发送内容超过4KB,无法传输,请分多次发送!','提示',MB_ICONINFORMATION+MB_OK);
end;
end;
procedure TForm1.richedit2KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if SendNw then
begin
richedit2.Clear;
SendNw:=false;
end;
end;
procedure TForm1.List3InfoTip(Sender: TObject; Item: TListItem;
var InfoTip: String);
begin
// try infotip:=infotip+' '+list3.ItemFocused.SubItems[1] ;except end;
end;
procedure TForm1.TimerMessBeepTimer(Sender: TObject);
begin
MessageBeep(7);
end;
procedure TForm1.SysAutoWrite(S1:string);
var FHistory:TextFile;
begin
try
AssignFile(FHistory,ExtractFilePath(Application.ExeName)+'AllHistory.txt');
if FileExists(ExtractFilePath(Application.ExeName)+'AllHistory.txt') then
begin
reset(FHistory);
append(FHistory);
writeln(FHistory,S1);
end
else
begin
rewrite(FHistory);
writeln(FHistory,S1);
end;
finally CloseFile(FHistory);
end;
end;
procedure TForm1.SysAutoRead();
var FHistory:TextFile;
str:string;
begin
try
AssignFile(FHistory,ExtractFilePath(Application.ExeName)+'AllHistory.txt');
if FileExists(ExtractFilePath(Application.ExeName)+'AllHistory.txt') then
begin
reset(FHistory);
memo1.Clear;
While Not Eof(FHistory) do
begin
readln(FHistory, str);
memo1.Lines.add(str);
end;
end
else
rewrite(FHistory);
finally
CloseFile(FHistory);
end;
end;
procedure TForm1.BhistoryClick(Sender: TObject);
begin
Panhis.Visible :=true;
panhis.BringToFront ;
SysAutoRead();
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
var FHistory:TextFile;
begin
if MessageBox(Handle, '确定要清空所有历史记录吗？', '系统提醒', MB_ICONQUESTION or MB_YESNO) = IDYES then
begin
AssignFile(FHistory,ExtractFilePath(Application.ExeName)+'AllHistory.txt');
reset(FHistory);
rewrite(FHistory);
CloseFile(FHistory);
memo1.Lines.Clear;
end;
end;
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
memo1.Lines.Clear;
panhis.Visible:=false;
panhis.SendToBack;
end;
procedure TForm1.SpeedButton3Click(Sender: TObject);
var FHistory:TextFile;
begin
if save1.Execute then
begin
if FileExists('AllHistory.txt') then
begin
memo1.Lines.SaveToFile(save1.FileName);
AssignFile(FHistory,ExtractFilePath(Application.ExeName)+'AllHistory.txt');
rewrite(FHistory);
CloseFile(FHistory);
memo1.Lines.Clear;
end;
end;
end;
procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
memo1.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'AllHistory.txt');
end;
end.