//客户端
代码
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.
//关于
代码
unit About;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls;
type
TAboutBox = class(TForm)
Panel1: TPanel;
ProgramIcon: TImage;
ProductName: TLabel;
Version: TLabel;
Copyright: TLabel;
Comments: TLabel;
OKButton: TButton;
procedure OKButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
AboutBox: TAboutBox;
implementation
{$R *.dfm}
procedure TAboutBox.OKButtonClick(Sender: TObject);
begin
CloseModal;
end;
end.
