Delphi笔记-Indy10.5.5 IdTcpServer 与 IdTcpClient Demo

unit
UntClt;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,

StdCtrls, UntGlb, IdGlobal, ExtCtrls, ImgList, jpeg, WinSock, IdIPWatch;

type

TForm1
=

class
(TForm)

stat1: TStatusBar;

img1: TImage;

lbl1: TLabel;

btn1: TButton;

chk1: TCheckBox;

edt1: TEdit;

btn2: TButton;

btn3: TButton;

btn4: TButton;

btn5: TButton;

grp1: TGroupBox;

lst1: TListBox;

idtcpclnt1: TIdTCPClient;

BalloonHint1: TBalloonHint;

il1: TImageList;

dlgOpen1: TOpenDialog;

ProgressBar1: TProgressBar;

btnCancle: TButton;

IdIPWatch1: TIdIPWatch;

procedure
btn1Click(Sender: TObject);

procedure
chk1Click(Sender: TObject);

procedure
idtcpclnt1Disconnected(Sender: TObject);

procedure
btn2Click(Sender: TObject);

procedure
idtcpclnt1Connected(Sender: TObject);

procedure
FormCreate(Sender: TObject);

procedure
btn5Click(Sender: TObject);

procedure
btn3Click(Sender: TObject);

procedure
btn4Click(Sender: TObject);

procedure
WMMOVE(
var
msg: TMessage);
message
WM_MOVE;

procedure
WMUSERMSG(
var
msg: TMessage);
message
WM_USERMSG;

procedure
ShowProgressBar(Visible: Boolean);

procedure
btnCancleClick(Sender: TObject);

private

{
Private declarations
}

ComputerName:
string
;

public

{
Public declarations
}

UserBreakAll: Boolean;

end
;

TFileThread
=

class
(TThread)

private

//
CB: TDataPack;

protected

procedure
Execute;
override
;

end
;

TMonitorThread
=

class
(TThread)

protected

procedure
Execute;
override
;

end
;

var

Form1: TForm1;

FileThread: TFileThread;

MonitorThread: TMonitorThread;

AllowDisconnectedEvent: Boolean
=
False;

function
SendARP(Destip, scrip: DWORD; pmacaddr: PDWORD;

VAR phyAddrlen: DWORD): DWORD;
stdcall
;
external

'
iphlpapi.dll
'
;

implementation

{
$R *.dfm
}

function
GetMacFromIP(IP: AnsiString): AnsiString;

type

Tinfo
=

array
[
0
..
7
]
of
Byte;

var

dwTargetIP: DWORD;

dwMacAddress:
array
[
0
..
1
]
of
DWORD;

dwMacLen: DWORD;

dwResult: DWORD;

X: Tinfo;

stemp: AnsiString;

iloop: integer;

begin

dwTargetIP :
=
Inet_Addr(PAnsiChar(IP));

dwMacLen :
=

6
;

dwResult :
=
SendARP(dwTargetIP,
0
, @dwMacAddress[
0
], dwMacLen);

case
dwResult
of

NO_ERROR:

begin

//
ShowMessage(
'
查到
'
);

X :
=
Tinfo(dwMacAddress);

for
iloop :
=

0

to

5

do

begin

stemp :
=
stemp
+
inttohex(X[iloop],
2
);

end
;

Result :
=
stemp;

end
;

ERROR_BAD_NET_NAME:

Result :
=

'
目标IPv4地址无法送达(Windows Vista 及以后版本错误)
'
;

ERROR_BUFFER_OVERFLOW:

Result :
=

'
PhyAddrLen参数小于6(Windows Vista 及以后版本错误)
'
;

ERROR_GEN_FAILURE:

Result :
=

'
目标IPv4地址无法送达(Windows Server 2003及之前版本错误)
'
;

ERROR_INVALID_PARAMETER:

Result :
=

'
pMacAddr或PhyAddrLen参数是一个NULL指针(Windows Server 2003及之前版本错误)
'
;

ERROR_INVALID_USER_BUFFER:

Result :
=

'
PhyAddrLen参数为零(Windows Server 2003及之前版本错误)
'
;

//
ERROR_NOT_FOUND:Result :
=
'
非INADDR_ANY的IP地址(IPv4地址为0.0.0.0)(Windows Vista 错误)
'
;

ERROR_NOT_SUPPORTED:

Result :
=

'
本机操作系统不支持该函数
'
;

else

Result :
=

'
未知
'
;

end
;

end
;

function
GetWindowsVersionString: AnsiString;

var

VI: TOSVersionInfoA;

begin

VI.dwOSVersionInfoSize :
=
SizeOf(TOSVersionInfoA);

if
GetVersionExA(VI)
then

with
VI
do

Result :
=
Trim(Format(
'
%d.%d build %d %s
'
, [dwMajorVersion,

dwMinorVersion, dwBuildNumber, szCSDVersion]))

else

Result :
=

''
;

end
;

function
GetWindowsVersion: String;
//
读取操作系统版本

var

AWin32Version: Extended;

os:
string
;

begin

os :
=

'
Windows
'
;

AWin32Version :
=
StrtoFloat(Format(
'
%d.%d
'
, [Win32MajorVersion,

Win32MinorVersion]));

if
Win32Platform
=
VER_PLATFORM_WIN32s
then

Result :
=
os
+

'
32
'

else

if
Win32Platform
=
VER_PLATFORM_WIN32_WINDOWS
then

begin

if
AWin32Version
=

4.0

then

Result :
=
os
+

'
95
'

else

if
AWin32Version
=

4.1

then

Result :
=
os
+

'
98
'

else

if
AWin32Version
=

4.9

then

Result :
=
os
+

'
Me
'

else

Result :
=
os
+

'
9x
'

end

else

if
Win32Platform
=
VER_PLATFORM_WIN32_NT
then

begin

if
AWin32Version
=

3.51

then

Result :
=
os
+

'
NT 3.51
'

else

if
AWin32Version
=

4.0

then

Result :
=
os
+

'
NT 4.0
'

else

if
AWin32Version
=

5.0

then

Result :
=
os
+

'
2000
'

else

if
AWin32Version
=

5.1

then

Result :
=
os
+

'
XP
'

else

if
AWin32Version
=

5.2

then

Result :
=
os
+

'
2003
'

else

if
AWin32Version
=

6.0

then

Result :
=
os
+

'
Vista
'

else

if
AWin32Version
=

6.1

then

Result :
=
os
+

'
7
'

else

Result :
=
os;

end

else

Result :
=
os
+

'
??
'
;

Result :
=
Result
+

'

'

+
GetWindowsVersionString;

end
;

procedure
TForm1.btn1Click(Sender: TObject);

begin

close;

end
;

procedure
TForm1.btn2Click(Sender: TObject);

var

i: integer;

begin

if
dlgOpen1.Execute(Handle)
then

begin

for
i :
=

0

to
dlgOpen1.Files.Count
-

1

do

lst1.Items.add(dlgOpen1.Files[i]);

end
;

grp1.Caption :
=
GroupText
+
Format(FileListString, [lst1.Count]);

end
;

procedure
TForm1.btn3Click(Sender: TObject);

begin

lst1.Clear;

grp1.Caption :
=
GroupText
+
Format(FileListString, [
0
]);

end
;

procedure
TForm1.btn4Click(Sender: TObject);

begin

lst1.DeleteSelected;

grp1.Caption :
=
GroupText
+
Format(FileListString, [lst1.Count]);

end
;

procedure
TForm1.btn5Click(Sender: TObject);

var

DlgText:
string
;

begin

if
idtcpclnt1.Connected
then

begin

if
lst1.Count
>

0

then

begin

DlgText :
=
Format(DlgSendFileText, [lst1.Count]);

if
Application.MessageBox(PChar(DlgText),
'
发送提示
'
,

MB_OKCANCEL
+
MB_ICONQUESTION)
=
IDOK
then

begin

ShowProgressBar(True);

FileThread :
=
TFileThread.Create(True);

FileThread.FreeOnTerminate :
=
True;

FileThread.Start;

end
;

end

else

ShowMessage(DlgSelectFile);

end

else

ShowMessage(DlgNoConnected);

end
;

procedure
TForm1.btnCancleClick(Sender: TObject);

begin

UserBreakAll :
=
True;

end
;

procedure
TForm1.chk1Click(Sender: TObject);

begin

idtcpclnt1.Host :
=
edt1.Text;

if
chk1.Checked
then

begin

try

Application.ProcessMessages;

idtcpclnt1.Connect;

AllowDisconnectedEvent :
=
True;

stat1.Panels[
1
].Text :
=
StaConnected;

except

ShowMessage(DlgConnectFailed);

end
;

end

else

begin

AllowDisconnectedEvent :
=
False;

idtcpclnt1.Disconnect;

end
;

chk1.Checked :
=
idtcpclnt1.Connected;

end
;

procedure
TForm1.FormCreate(Sender: TObject);

var

n: Cardinal;

Name:
array
[
0
.. MAX_COMPUTERNAME_LENGTH]
of
Char;

begin

n :
=
MAX_COMPUTERNAME_LENGTH
+

1
;

GetComputerName(name, n);

ComputerName :
=

string
(Name);

MonitorThread :
=
TMonitorThread.Create(True);

MonitorThread.FreeOnTerminate :
=
True;

MonitorThread.Start;

end
;

procedure
TForm1.idtcpclnt1Connected(Sender: TObject);

var

bbuf: TIdBytes;

buf: TDataPack;

begin

bbuf :
=

nil
;

FillChar(buf, SizeOf(buf),
''
);

buf.Command :
=
cmdSetName;

StrPCopy(buf.ClientInfo.ClientName ,ComputerName);

StrPCopy(buf.ClientInfo.ClientOS,GetWindowsVersion);

StrPCopy(buf.ClientInfo.ClientACTIP ,GetMacFromIP(IdIPWatch1.LocalIP));

bbuf :
=
RawToBytes(buf, SizeOf(buf));

idtcpclnt1.IOHandler.Write(bbuf);

end
;

procedure
TForm1.idtcpclnt1Disconnected(Sender: TObject);

begin

stat1.Panels[
1
].Text :
=
StaDisconnected;

chk1.Checked :
=
False;

end
;

procedure
TForm1.ShowProgressBar(Visible: Boolean);

begin

ProgressBar1.Visible :
=
Visible;

btnCancle.Visible :
=
Visible;

end
;

procedure
TForm1.WMMOVE(
var
msg: TMessage);

begin

//

inherited
;

//

if
Assigned(frmProgress)
then

//
frmProgress.Position :
=
poMainFormCenter;

end
;

procedure
TForm1.WMUSERMSG(
var
msg: TMessage);

begin

case
msg.WParam
of

1
:

ShowMessage(Format(DlgFileSendOk, [msg.LParam]));

2
:

stat1.Panels[
1
].Text :
=

string
(PChar(msg.LParam));

3
:

ProgressBar1.Position :
=
msg.LParam;

4
:

ProgressBar1.Max :
=
msg.LParam;

5
:

idtcpclnt1.OnDisconnected(Self);

6
:

ShowMessage(DlgExcept);

7
:

ShowProgressBar(False);

end
;

end
;

{
TFileThread
}

procedure
TFileThread.Execute;

var

FileName:
string
;

buf: TDataPack;

bbuf: TIdBytes;

i, j, SendTimes, RemainLen, h, FileLen, SentFilesNum,

ClientReadedBytes: integer;

begin

try

Form1.UserBreakAll :
=
False;

SentFilesNum :
=

0
;

for
i :
=

0

to
Form1.lst1.Count
-

1

do

begin

if
Form1.UserBreakAll
then

Break;

FileName :
=
Form1.lst1.Items[i];

//
frmProgress.lbl1.Caption :
=
FileName;

//
frmProgress.pb1.Position :
=

0
;

PostMessage(Form1.Handle, WM_USERMSG,
2
, integer(PChar(FileName)));

PostMessage(Form1.Handle, WM_USERMSG,
3
,
0
);

h :
=
FileOpen(FileName, fmOpenRead);

if
h
>

0

then

begin

try

FileLen :
=
GetFileSize(h,
nil
);

SendTimes :
=
FileLen
div
SEND_BUF;

RemainLen :
=
FileLen
mod
SEND_BUF;

//
frmProgress.pb1.Max :
=
FileLen;

PostMessage(Form1.Handle, WM_USERMSG,
4
, FileLen);

FillChar(buf.ClientInfo, SizeOf(buf.ClientInfo),
''
);

buf.Command :
=
cmdSendFile;

StrPCopy(buf.FileName,ExtractFileName(FileName));

buf.FileSize :
=
FileLen;

buf.Flags :
=

0
;
//
新建

for
j :
=

1

to
SendTimes
do

begin

if
Form1.UserBreakAll
then

Break;

if

not
Form1.idtcpclnt1.Connected
then

Break;

ClientReadedBytes :
=
FileRead(h, buf.FileData, SEND_BUF);

buf.ReadBytes :
=
ClientReadedBytes;

bbuf :
=

nil
;

bbuf :
=
RawToBytes(buf, SizeOf(buf));

Form1.idtcpclnt1.IOHandler.Write(bbuf);

buf.Flags :
=

1
;
//
续传

//
frmProgress.pb1.Position :
=
j
*
SEND_BUF;

PostMessage(Form1.Handle, WM_USERMSG,
3
, j
*
SEND_BUF);

end
;

if
RemainLen
>

0

then

begin

if

not
Form1.idtcpclnt1.Connected
then

Break;

ClientReadedBytes :
=
FileRead(h, buf.FileData, RemainLen);

buf.ReadBytes :
=
ClientReadedBytes;

bbuf :
=

nil
;

bbuf :
=
RawToBytes(buf, SizeOf(buf));

Form1.idtcpclnt1.IOHandler.Write(bbuf);

PostMessage(Form1.Handle, WM_USERMSG,
3
, FileLen);

end
;

finally

FileClose(h);

end
;

if
(
not
Form1.UserBreakAll)
then

inc(SentFilesNum);

end
;

end
;

PostMessage(Form1.Handle, WM_USERMSG,
7
,
0
);

PostMessage(Form1.Handle, WM_USERMSG,
1
, SentFilesNum);

if
Form1.idtcpclnt1.Connected
and
Form1.UserBreakAll
then

begin

bbuf :
=

nil
;

buf.Command :
=
cmdUserbreak;

bbuf :
=
RawToBytes(buf, SizeOf(buf));

Form1.idtcpclnt1.IOHandler.Write(bbuf);

end
;

except

PostMessage(Form1.Handle, WM_USERMSG,
7
,
0
);

PostMessage(Form1.Handle, WM_USERMSG,
6
,
0
);

AllowDisconnectedEvent :
=
False;

Form1.idtcpclnt1.Disconnect;

Terminate;

end
;

end
;

{
TMonitorThread
}

procedure
TMonitorThread.Execute;

begin

while

not
Terminated
do

begin

if

not
Form1.idtcpclnt1.Connected
then

if
AllowDisconnectedEvent
then

begin

AllowDisconnectedEvent :
=
False;

PostMessage(Form1.Handle, WM_USERMSG,
5
,
0
);

end
;

Sleep(
100
);

end
;

end
;

end
.

//公共单元

unit
UntGlb;

interface

uses

Messages,Windows, SysUtils,Classes ;

const

WM_USERMSG
=
WM_USER
+
1002
;

WM_USERFILE
=
WM_USER
+
1003
;

ADD_LIST
=

0
;

DEL_LIST
=
1
;

UPD_STA
=
2
;

SHOW_R
=
3
;

SEND_BUF
=

1024
*
20
;

REV
=

'
REV
'
;

IniFileName
=

'
Server.ini
'
;

type

TCommand
=
(cmdSetName,cmdSendFile,cmdUserbreak,cmdGetClientInfo);

TClientInfo
=

packed

record

ClientName        :
array
[
0
..
49
]
of
Char;

ClientIP          :
array
[
0
..
14
]
of
Char;

ClientID          :
array
[
0
..
9
]
of
Char;

ClientACTIP       :
array
[
0
..
17
]
of
Char;

ClientOS          :
array
[
0
..
49
]
of
Char;

ClientStatus      :
array
[
0
..
9
]
of
Char;

ReceivedFileName  :
array
[
0
..
255
]
of
Char;

ReceivedPersent,

ReceivedFileSize  : Cardinal;

Flags             : Integer;

IdleTime          : TTime;

Isbusy            : Boolean;

end
;

TDataPack
=

packed

record

Flags       :   Integer;

FileSize,

ReadBytes   :   Cardinal;

Command     :   TCommand;

ClientInfo  :   TClientInfo;

FileName    :
array
[
0
..
255
]
of
Char;

FileData    :
array
[
0
..SEND_BUF
-
1
]
of
Byte;

end
;

resourcestring

MainFormCaption
=

'
Indy10.5.5 IdTcpServer Demo
'
;

StringsObjectName
=

'
object
'
;

GroupText
=

'
发送文件列表
'
;

FileListString
=

'
(%d个文件)
'
;

DlgCreateIniFailed
=

'
创建配置文件失败,请检查磁盘空间
'
;

DlgIniFileBreak
=

'
配置文件损坏，重新创建失败
'
;

DlgIniNotExists
=

'
配置文件不存在
'
;

DlgIniBusy
=

'
配置文件被占用
'
;

DlgSendFileText
=

'
您确定要发送列表中的%d个文件吗？
'
;

DlgSendFileCaption
=

'
发送提示
'
;

DlgFileSendOk
=

'
%d个文件发送成功
'
;

DlgSelectFile
=

'
请选择待发送的文件
'
;

DlgNoConnected
=

'
未连接服务器
'
;

DlgFileExists
=

'
文件%s已存在，要替换吗?
'
;

DlgLogOk
=

'
日志保持成功
'
;

DlgLogFailed
=

'
日志保存失败
'
;

DlgConnectFailed
=

'
连接被拒绝，可能服务器没有开启
'
;

DlgExcept
=

'
服务器端异常断开，文件传输中止!
'
;

StaInitText
=

'
服务器未开启
'
;

StaText
=

'
客户端连接数:%d个
'
;

StaConnected
=

'
已链接到服务器
'
;

StaDisconnected
=

'
已从服务器断开
'
;

StaServerStart
=

'
服务器开启
'
;

StaServerClose
=

'
服务器关闭
'
;

StaReceivedPersent
=

'
接收文件：%s--(%u%%)
'
;

LogTxt
=

'
------服务器操作日志------
'
+
#
13
+
#
10
;

LogServerStart
=

'
【服务器开启--%s】
'
;

LogServerClose
=

'
【服务器关闭--%s】
'
;

LogClientdisConnected
=

'
【客户端：%s,%s】从服务器断开--%s
'
;

LogClientConnected
=

'
【客户端：%s,%s】连接到服务器--%s
'
;

LogReceiveFile
=

'
【客户端：%s】正在发送文件： %s(大小：%u字节)--%s
'
;

LogReceiveFileOk
=

'
【客户端：%s】发送的文件： %s  接收完毕，保存在REV子目录下--%s
'
;

LogUerBreakSend
=

'
【客户端：%s】用户终止文件： %s  传送--%s
'
;

LogClientStateSleep
=

'
空闲
'
;

LogClientStateBusy
=

'
数据传输中
'
;

LogClientTimeOut
=

'
客户端空闲超时，断开连接...
'
;

bhBalloonHint
=

'
欢迎使用,双击显示界面
'
;

bhBalloonTitle
=

'
Indy10.5.5Demo
'
;

dlgInputBoxCpt
=

'
客户端连接数设置
'
;

dlgInputBox
=

'
最大连接数
'
;

implementation

end
.