Delphi笔记-Indy10.5.5 IdTcpServer 与 IdTcpClient Demo --服务器端
代码
unit
UntMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons, ComCtrls, XPMan, ExtCtrls, StdCtrls, Menus, IdContext,
IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadDefault, IdBaseComponent,
IdComponent, IdCustomTCPServer, IdTCPServer, ImgList, IdGlobal, UntGlb,
IOUtils, IdThread,
RibbonLunaStyleActnCtrls, ABOUT, ToolWin, PlatformDefaultStyleActnCtrls,
ActnPopup, ExtDlgs, jpeg, ShellCtrls, DateUtils, IdSchedulerOfThreadPool;
type
TForm1
=
class
(TForm)
stat1: TStatusBar;
trycn1: TTrayIcon;
xpmnfst1: TXPManifest;
mm1: TMainMenu;
mniN1: TMenuItem;
mniN2: TMenuItem;
mniN4: TMenuItem;
mniN5: TMenuItem;
mniN7: TMenuItem;
mniN3: TMenuItem;
mniN8: TMenuItem;
il1: TImageList;
idtcpsrvr1: TIdTCPServer;
BalloonHint1: TBalloonHint;
PopActMemo: TPopupActionBar;
mniNClear: TMenuItem;
mniN6: TMenuItem;
mniNSave: TMenuItem;
PopActBall: TPopupActionBar;
mniN9: TMenuItem;
mniN13: TMenuItem;
mniN10: TMenuItem;
mniN11: TMenuItem;
mniN12: TMenuItem;
il3: TImageList;
dlgSave1: TSaveTextFileDialog;
il2: TImageList;
pgc1: TPageControl;
ts1: TTabSheet;
ts2: TTabSheet;
grp2: TGroupBox;
mmo1: TMemo;
grp1: TGroupBox;
lv1: TListView;
ts3: TTabSheet;
ShellListView2: TShellListView;
ShellTreeView1: TShellTreeView;
PopupMenu1: TPopupMenu;
mniN14: TMenuItem;
mniN15: TMenuItem;
mniN16: TMenuItem;
mniN17: TMenuItem;
mniN18: TMenuItem;
mniN19: TMenuItem;
PopupMenu2: TPopupMenu;
mniN20: TMenuItem;
mniN21: TMenuItem;
mniN22: TMenuItem;
tmr1: TTimer;
IdSchedulerOfThreadPool1: TIdSchedulerOfThreadPool;
mniN23: TMenuItem;
procedure
mniN13Click(Sender: TObject);
procedure
mniN7Click(Sender: TObject);
procedure
WndProc(
var
Msg: TMessage);
override
;
procedure
N14Click(Sender: TObject);
procedure
mniN2Click(Sender: TObject);
procedure
idtcpsrvr1Execute(AContext: TIdContext);
procedure
FormCreate(Sender: TObject);
procedure
idtcpsrvr1Connect(AContext: TIdContext);
procedure
idtcpsrvr1Disconnect(AContext: TIdContext);
procedure
AddList(AContext: TIdContext);
procedure
DelList(AContext: TIdContext);
procedure
UpdSta;
procedure
WMUSERMSG(
var
Msg: TMessage);
message
WM_USERMSG;
procedure
WMUSERFILE(
var
Msg: TMessage);
message
WM_USERFILE;
procedure
mniN5Click(Sender: TObject);
procedure
FormCloseQuery(Sender: TObject;
var
CanClose: Boolean);
procedure
DisConnectAllClient;
procedure
mniN8Click(Sender: TObject);
procedure
mniN9Click(Sender: TObject);
procedure
mniN11Click(Sender: TObject);
procedure
mniN12Click(Sender: TObject);
procedure
trycn1DblClick(Sender: TObject);
procedure
PopActMemoPopup(Sender: TObject);
procedure
mniNClearClick(Sender: TObject);
procedure
mniNSaveClick(Sender: TObject);
procedure
dlgSave1CanClose(Sender: TObject;
var
CanClose: Boolean);
procedure
FormDestroy(Sender: TObject);
procedure
lv1SelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
procedure
lv1ItemChecked(Sender: TObject; Item: TListItem);
procedure
mniN14Click(Sender: TObject);
procedure
mniN16Click(Sender: TObject);
procedure
mniN17Click(Sender: TObject);
procedure
mniN18Click(Sender: TObject);
procedure
mniN19Click(Sender: TObject);
procedure
mniN22Click(Sender: TObject);
procedure
tmr1Timer(Sender: TObject);
procedure
mniN23Click(Sender: TObject);
private
{
Private declarations
}
//
定义一个私有成员，保存连接对象AContext(ListView控件Items成员没有AdddObject方法，无法保存对象)
FStrings: TStringList;
public
{
Public declarations
}
end
;
//
这里声明一个自定义类，在Form.Create方法里面使用
type
TMyContextClass
=
class
(TIdServerContext)
ClientInfo: TClientInfo;
end
;
var
Form1: TForm1;
implementation
{
$R *.dfm
}
procedure
TForm1.WMUSERFILE(
var
Msg: TMessage);
var
ClientIP:
string
;
str:
string
;
path:
string
;
size: Cardinal;
Persent: Cardinal;
m: Integer;
begin
ClientIP :
=
TMyContextClass(Msg.LParam).Binding.PeerIP;
str :
=
TMyContextClass(Msg.LParam).ClientInfo.ReceivedFileName;
Persent :
=
TMyContextClass(Msg.LParam).ClientInfo.ReceivedPersent;
size :
=
TMyContextClass(Msg.LParam).ClientInfo.ReceivedFileSize;
m :
=
FStrings.IndexOfObject(TMyContextClass(Msg.LParam));
with
mmo1.Lines
do
begin
case
Msg.WParam
of
0
:
begin
Add(format(LogReceiveFile, [ClientIP, str, size, DateTimeToStr(Now)])
);
lv1.Items.BeginUpdate;
try
lv1.Items[m].SubItems[
4
] :
=
LogClientStateBusy;
//
接收文件时更新状态为 忙
finally
lv1.Items.EndUpdate;
end
;
end
;
1
:
begin
Add(format(LogReceiveFileOk, [ClientIP, str, DateTimeToStr(Now)]));
lv1.Items.BeginUpdate;
try
lv1.Items[m].SubItems[
4
] :
=
LogClientStateSleep;
//
文件接收完毕时更新状态为 空闲
finally
lv1.Items.EndUpdate;
end
;
end
;
2
:
begin
path :
=
ExtractFilePath(ParamStr(
0
))
+
REV
+
'
\
'
;
Add(format(LogUerBreakSend, [ClientIP, str, DateTimeToStr(Now)]));
DeleteFile(path
+
str);
lv1.Items.BeginUpdate;
try
lv1.Items[m].SubItems[
4
] :
=
LogClientStateSleep;
//
用户终止传送时更新状态为 空闲
finally
lv1.Items.EndUpdate;
end
;
end
;
3
:
stat1.Panels[
2
].Text :
=
format(StaReceivedPersent, [str, Persent]);
end
;
end
;
end
;
procedure
TForm1.WMUSERMSG(
var
Msg: TMessage);
begin
if
Msg.Msg
=
WM_USERMSG
then
begin
case
Msg.WParam
of
ADD_LIST:
AddList(TMyContextClass(Msg.LParam));
DEL_LIST:
DelList(TMyContextClass(Msg.LParam));
SHOW_R:
Visible:
=
True;
end
;
stat1.Panels[
1
].Text :
=
format(StaText, [lv1.Items.Count]);
end
;
end
;
procedure
TForm1.WndProc(
var
Msg: TMessage);
begin
if
((Msg.Msg
=
WM_SYSCOMMAND)
and
(Msg.WParam
=
SC_CLOSE))
or
((Msg.Msg
=
WM_SYSCOMMAND)
and
(Msg.WParam
=
SC_MINIMIZE))
then
begin
Msg.Msg :
=
0
;
mniN13.Click;
end
;
inherited
;
end
;
procedure
TForm1.AddList(AContext: TIdContext);
begin
lv1.Items.BeginUpdate;
try
with
lv1.Items.Add
do
begin
Caption :
=
AContext.Binding.PeerIP;
//
IP
ImageIndex :
=
0
;
SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientACTIP );
//
物理地址
SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientName);
//
计算机名
SubItems.Add(DateTimeToStr(Now));
//
连接时间
SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientOS);
//
操作系统
SubItems.Add(LogClientStateSleep);
//
状态
end
;
FStrings.AddObject(StringsObjectName, AContext);
finally
lv1.Items.EndUpdate;
end
;
mmo1.Lines.Add(format(LogClientConnected, [AContext.Binding.PeerIP,
TMyContextClass(AContext).ClientInfo.ClientName, DateTimeToStr(Now)]));
end
;
procedure
TForm1.DelList(AContext: TIdContext);
var
i: Integer;
begin
i :
=
FStrings.IndexOfObject(AContext);
FStrings.Delete(i);
lv1.Items.BeginUpdate;
try
if
Assigned(lv1.Items[i])
then
lv1.Items.Delete(i);
finally
lv1.Items.EndUpdate;
end
;
mmo1.Lines.Add(format(LogClientdisConnected, [AContext.Binding.PeerIP,
TMyContextClass(AContext).ClientInfo.ClientName, DateTimeToStr(Now)]));
end
;
procedure
TForm1.DisConnectAllClient;
var
i: Integer;
begin
for
i :
=
0
to
FStrings.Count
-
1
do
begin
TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
end
;
end
;
procedure
TForm1.dlgSave1CanClose(Sender: TObject;
var
CanClose: Boolean);
var
h: Integer;
begin
CanClose :
=
False;
if
FileExists(dlgSave1.FileName)
then
begin
if
MessageDlg(format(DlgFileExists, [dlgSave1.FileName]), mtInformation,
[mbYes, mbNo],
0
)
=
mrYes
then
begin
DeleteFile(dlgSave1.FileName);
h :
=
FileCreate(dlgSave1.FileName);
FileClose(h);
CanClose :
=
True;
end
;
end
else
begin
h :
=
FileCreate(dlgSave1.FileName);
FileClose(h);
CanClose :
=
True;
end
;
end
;
procedure
TForm1.FormCloseQuery(Sender: TObject;
var
CanClose: Boolean);
begin
CanClose :
=
False;
DisConnectAllClient;
CanClose :
=
True;
end
;
procedure
TForm1.FormCreate(Sender: TObject);
var
path:
string
;
IniFile:
string
;
h: THandle;
i: Integer;
begin
//
这里重新赋值 idtcpsrvr1.ContextClass属性。在Context被创建时，将以 TMyContextClass 类来创建。
//
TIdListenerThread.LContext :
=
Server.FContextClass.Create(LPeer, LYarn, Server.Contexts);
//
详见IdCustomTcPServer.pas单元956行
idtcpsrvr1.ContextClass :
=
TMyContextClass;
FStrings :
=
TStringList.Create;
lv1.Checkboxes :
=
True;
trycn1.BalloonHint :
=
bhBalloonHint;
trycn1.BalloonTitle :
=
bhBalloonTitle;
path :
=
ExtractFilePath(ParamStr(
0
))
+
REV;
if
not
DirectoryExists(path)
then
TDirectory.CreateDirectory(path);
stat1.Panels[
0
].Text :
=
StaInitText;
ShellTreeView1.path :
=
ExtractFilePath(ParamStr(
0
))
+
REV;
//
检查配置文件
IniFile :
=
ExtractFilePath(ParamStr(
0
))
+
IniFileName;
if
not
FileExists(IniFile)
then
begin
h :
=
FileCreate(IniFile, fmOpenReadWrite);
try
i :
=
$
10000
;
//
不自动开启
--
默认值
if
FileWrite(h, i,
4
)
<>
4
then
begin
ShowMessage(DlgCreateIniFailed);
Application.Terminate;
end
;
finally
FileClose(h);
end
;
end
else
begin
h :
=
FileOpen(IniFile, fmOpenReadWrite);
try
if
FileRead(h, i,
4
)
=
4
then
begin
case
i
of
$
10000
:
begin
idtcpsrvr1.Active :
=
False;
mniN22.Checked :
=
False;
end
;
$
11111
:
begin
mniN2.Click;
mniN22.Checked :
=
True;
end
;
else
FileClose(h);
DeleteFile(IniFile);
h :
=
FileCreate(IniFile, fmOpenReadWrite);
i :
=
$
10000
;
//
不自动开启
--
默认值
if
FileWrite(h, i,
4
)
<>
4
then
begin
ShowMessage(DlgIniFileBreak);
Application.Terminate;
end
;
end
;
end
;
finally
FileClose(h);
end
;
end
;
end
;
procedure
TForm1.FormDestroy(Sender: TObject);
begin
FStrings.Free;
end
;
procedure
TForm1.idtcpsrvr1Connect(AContext: TIdContext);
//
这里不能直接操作VCL控件，OnConnect，OnDisConnect,OnException,OnExecute都是在线程里面执行
//
要采用SendMessage发送消息通知主线程操作VCL的方法才是可取的；
//
详见IdCustomTcPServer.pas单元961
-
964
行
begin
//
TMyContextClass(AContext).ClientInfo.ClientIP :
=
AContext.Binding.PeerIP;
//
SendMessage(Handle,WM_USERMSG,ADD_LIST,LongInt(AContext ));
//
通知主线更新VCL控件
end
;
procedure
TForm1.idtcpsrvr1Disconnect(AContext: TIdContext);
begin
SendMessage(Handle, WM_USERMSG, DEL_LIST, LongInt(AContext));
//
通知主线更新VCL控件
end
;
procedure
TForm1.idtcpsrvr1Execute(AContext: TIdContext);
var
Buf: TDataPack;
BByte: TIdBytes;
path:
string
;
Files:
string
;
h: Integer;
Received: Cardinal;
begin
//
接收文件存入当前程序REV子目录下
path :
=
ExtractFilePath(Application.ExeName)
+
REV
+
'
\
'
;
AContext.Connection.IOHandler.ReadBytes(BByte, SizeOf(Buf), False);
TMyContextClass(AContext).ClientInfo.Isbusy :
=
True;
BytesToRaw(BByte, Buf, SizeOf(Buf));
if
TMyContextClass(AContext).ClientInfo.ReceivedFileName
<>
Buf.FileName
then
Move(Buf.FileName,TMyContextClass(AContext).ClientInfo.ReceivedFileName,SizeOf(buf.FileName));
TMyContextClass(AContext).ClientInfo.ReceivedFileSize :
=
Buf.FileSize;
case
Buf.Command
of
cmdSetName:
begin
with
TMyContextClass(AContext).ClientInfo
do
begin
ClientName :
=
Buf.ClientInfo.ClientName;
ClientOS :
=
Buf.ClientInfo.ClientOS;
ClientIP :
=
Buf.ClientInfo.ClientIP;
ClientACTIP:
=
buf.ClientInfo.ClientACTIP;
IdleTime :
=
Time;
Isbusy :
=
False;
end
;
SendMessage(Handle, WM_USERMSG, ADD_LIST, LongInt(AContext));
end
;
cmdSendFile:
begin
try
Files :
=
path
+
Buf.FileName;
case
Buf.Flags
of
0
:
begin
SendMessage(Handle, WM_USERFILE,
0
, LongInt(AContext));
if
FileExists(Files)
then
DeleteFile(Files);
h :
=
FileCreate(Files, fmOpenReadWrite);
end
;
1
:
h :
=
FileOpen(Files, fmOpenReadWrite);
end
;
FileSeek(h,
0
,
2
);
FileWrite(h, Buf.FileData, Buf.ReadBytes);
Received :
=
GetFileSize(h,
nil
);
FileClose(h);
TMyContextClass(AContext).ClientInfo.ReceivedPersent :
=
Trunc
((Received
/
Buf.FileSize)
*
100
);
SendMessage(Handle, WM_USERFILE,
3
, LongInt(AContext));
if
Received
=
Buf.FileSize
then
begin
SendMessage(Handle, WM_USERFILE,
1
, LongInt(AContext));
end
;
except
(*
如果出现异常，极大的可能是：
客户端与服务器端正在进行数据传输的同时，服务器端突然断开连接
*)
//
if
not
AContext.Connection.IOHandler.Opened
then
//
AContext.Connection.IOHandler.InputBuffer.Clear;
end
;
end
;
cmdUserbreak:
begin
SendMessage(Handle, WM_USERFILE,
2
, LongInt(AContext));
end
;
end
;
TMyContextClass(AContext).ClientInfo.IdleTime :
=
Time;
TMyContextClass(AContext).ClientInfo.Isbusy :
=
False;
end
;
procedure
TForm1.lv1ItemChecked(Sender: TObject; Item: TListItem);
begin
if
Item.Checked
then
mniN5.Enabled :
=
True
else
mniN5.Enabled :
=
False;
end
;
procedure
TForm1.lv1SelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
begin
if
Selected
then
Item.Checked :
=
True
else
Item.Checked :
=
False;
end
;
procedure
TForm1.mniN11Click(Sender: TObject);
begin
AboutBox.ShowModal;
end
;
procedure
TForm1.mniN12Click(Sender: TObject);
begin
Close;
end
;
procedure
TForm1.mniN13Click(Sender: TObject);
begin
if
Visible
then
begin
Visible :
=
False;
trycn1.ShowBalloonHint;
end
;
end
;
procedure
TForm1.mniN14Click(Sender: TObject);
begin
ShellListView2.Refresh;
end
;
procedure
TForm1.mniN16Click(Sender: TObject);
var
path:
string
;
begin
path :
=
ShellTreeView1.path;
ShellListView2.ViewStyle :
=
vsIcon;
ShellTreeView1.path :
=
path;
end
;
procedure
TForm1.mniN17Click(Sender: TObject);
var
path:
string
;
begin
path :
=
ShellTreeView1.path;
ShellListView2.ViewStyle :
=
vsSmallIcon;
ShellTreeView1.path :
=
path;
end
;
procedure
TForm1.mniN18Click(Sender: TObject);
var
path:
string
;
begin
path :
=
ShellTreeView1.path;
ShellListView2.ViewStyle :
=
vsList;
ShellTreeView1.path :
=
path;
end
;
procedure
TForm1.mniN19Click(Sender: TObject);
var
path:
string
;
begin
path :
=
ShellTreeView1.path;
ShellListView2.ViewStyle :
=
vsReport;
ShellTreeView1.path :
=
path;
end
;
procedure
TForm1.N14Click(Sender: TObject);
begin
Close;
end
;
procedure
TForm1.mniN9Click(Sender: TObject);
begin
if
not
Visible
then
Visible :
=
True
else
Visible :
=
False;
end
;
procedure
TForm1.mniNClearClick(Sender: TObject);
begin
mmo1.ReadOnly :
=
False;
mmo1.Text :
=
''
;
mmo1.ReadOnly :
=
True;
end
;
procedure
TForm1.mniNSaveClick(Sender: TObject);
var
h: THandle;
TxtFileName:
string
;
n, m: Integer;
tmp: AnsiString;
begin
if
mmo1.Text
<>
''
then
begin
if
dlgSave1.Execute
then
begin
tmp :
=
LogTxt
+
mmo1.Text;
n :
=
Length(tmp);
TxtFileName :
=
dlgSave1.FileName;
h :
=
FileOpen(TxtFileName, fmOpenReadWrite);
m :
=
FileWrite(h, tmp[
1
], n);
FileClose(h);
if
m
=
n
then
ShowMessage(DlgLogOk)
else
ShowMessage(DlgLogFailed);
end
;
end
;
end
;
procedure
TForm1.PopActMemoPopup(Sender: TObject);
begin
if
mmo1.Text
<>
''
then
begin
mniNClear.Enabled :
=
True;
mniNSave.Enabled :
=
True;
end
else
begin
mniNClear.Enabled :
=
False;
mniNSave.Enabled :
=
False;
end
;
end
;
procedure
TForm1.tmr1Timer(Sender: TObject);
var
i: Integer;
tmpTime: TTime;
AContextIdleTime: TTime;
AContextIsbusy: Boolean;
begin
tmpTime :
=
Time;
for
i :
=
0
to
FStrings.Count
-
1
do
begin
AContextIdleTime :
=
TMyContextClass(FStrings.Objects[i])
.ClientInfo.IdleTime;
AContextIsbusy :
=
TMyContextClass(FStrings.Objects[i]).ClientInfo.Isbusy;
if
(IncSecond(AContextIdleTime,
60
*
5
)
<
tmpTime)
and
(
not
AContextIsbusy)
then
TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
end
;
end
;
procedure
TForm1.trycn1DblClick(Sender: TObject);
begin
mniN9.Click;
end
;
procedure
TForm1.mniN22Click(Sender: TObject);
var
h: THandle;
i: Integer;
IniFile:
string
;
IsAutoServer: Boolean;
begin
IniFile :
=
ExtractFilePath(ParamStr(
0
))
+
IniFileName;
if
mniN22.Checked
then
begin
i :
=
$
11111
;
IsAutoServer :
=
True;
end
else
begin
i :
=
$
10000
;
IsAutoServer :
=
False;
end
;
if
not
FileExists(IniFile)
then
begin
ShowMessage(DlgIniNotExists);
mniN22.Checked :
=
not
IsAutoServer;
end
else
begin
h :
=
FileOpen(IniFile, fmOpenReadWrite);
if
h
>
0
then
begin
try
if
FileWrite(h, i,
4
)
<>
4
then
mniN22.Checked :
=
not
IsAutoServer;
finally
FileClose(h);
end
;
end
else
begin
ShowMessage(DlgIniBusy);
mniN22.Checked :
=
not
IsAutoServer;
end
;
end
;
end
;
procedure
TForm1.mniN23Click(Sender: TObject);
var
MaxConnection:
string
;
begin
MaxConnection:
=
InputBox(dlgInputBoxCpt,dlgInputBox,
'
20
'
);
//
default
20
ShowMessage(MaxConnection);
end
;
procedure
TForm1.mniN2Click(Sender: TObject);
begin
if
mniN2.Checked
then
begin
idtcpsrvr1.Active :
=
True;
stat1.Panels[
0
].Text :
=
StaServerStart;
mmo1.Lines.Add(format(LogServerStart, [DateTimeToStr(Now)]));
end
else
begin
DisConnectAllClient;
idtcpsrvr1.Active :
=
False;
stat1.Panels[
0
].Text :
=
StaServerClose;
mmo1.Lines.Add(format(LogServerClose, [DateTimeToStr(Now)]));
end
;
end
;
procedure
TForm1.mniN5Click(Sender: TObject);
var
i: Integer;
begin
for
i :
=
0
to
lv1.Items.Count
-
1
do
begin
if
lv1.Items[i].Checked
then
TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
end
;
end
;
procedure
TForm1.mniN7Click(Sender: TObject);
begin
Close;
end
;
procedure
TForm1.mniN8Click(Sender: TObject);
begin
AboutBox.ShowModal;
end
;
procedure
TForm1.UpdSta;
begin
stat1.Panels[
1
].Text :
=
format(StaText, [lv1.Items.Count]);
end
;
end
.
代码
program
Server;
uses
Windows,
Messages,
Forms,
UntMain
in
'
UntMain.pas
'
{
Form1
}
,
UntGlb
in
'
UntGlb.pas
'
,
ABOUT
in
'
ABOUT.pas
'
{
AboutBox
}
;
{
$R *.res
}
var
MainForm: HWND;
begin
MainForm :
=
FindWindow(
'
TForm1
'
, PChar(MainFormCaption));
if
MainForm
>
0
then
begin
PostMessage(MainForm, WM_USERMSG, SHOW_R,
0
);
Exit;
end
;
Application.Initialize;
Application.MainFormOnTaskbar :
=
True;
Application.CreateForm(TForm1, Form1);
Application.MainForm.Caption :
=
MainFormCaption;
Application.CreateForm(TAboutBox, AboutBox);
Application.Run;
end
.