1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
| unit ftp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdAntiFreezeBase, IdAntiFreeze, IdComponent, IdTCPConnection,
IdTCPClient, IdFTP, IdBaseComponent, IdIntercept, IdLogBase, IdLogDebug,
Menus, StdCtrls, ComCtrls, Buttons, ExtCtrls;
type
Tftpframe = class(TFrame)
StatusBar2: TStatusBar;
p2: TPanel;
Label10: TLabel;
CommandPanel: TPanel;
btnrename: TBitBtn;
bntDelete: TBitBtn;
btnrmdir: TBitBtn;
btnmkdir: TBitBtn;
btnrefresh: TBitBtn;
btnviewfile: TBitBtn;
btnupload: TBitBtn;
btndownload: TBitBtn;
btnabort: TBitBtn;
ProgressBar1: TProgressBar;
Panel3: TPanel;
CurrentDirEdit: TEdit;
btnFTPChDir: TBitBtn;
btnback: TBitBtn;
p3: TPanel;
Debug: TBitBtn;
uploadOpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
PopupMenu1: TPopupMenu;
IdLogDebug1: TIdLogDebug;
IdFTP1: TIdFTP;
IdAntiFreeze1: TIdAntiFreeze;
btncommand: TBitBtn;
btnoption: TBitBtn;
btnclose: TBitBtn;
btnOpen: TBitBtn;
Panel1: TPanel;
Directorylistbox: TListBox;
procedure btnOpenClick(Sender: TObject);
procedure btnOptionClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure IdLogDebug1LogItem(ASender: TComponent; var AText: String);
procedure DebugClick(Sender: TObject);
procedure btnuploadClick(Sender: TObject);
procedure btnFTPChDirClick(Sender: TObject);
procedure DirectoryListBoxDblClick(Sender: TObject);
procedure bntDeleteClick(Sender: TObject);
procedure btnabortClick(Sender: TObject);
procedure btnbackClick(Sender: TObject);
procedure IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
const asStatusText: String);
procedure IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
procedure IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
procedure IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
procedure btnmkdirClick(Sender: TObject);
private
AbortTransfer: Boolean;
TransferrignData: Boolean;
BytesToTransfer: LongWord;
STime: TDateTime;
procedure ChageDir(DirName: String);
procedure SetFunctionButtons(AValue: Boolean);
public
end;
implementation
uses ftpoption1, ftpdebug;
Var
AverageSpeed: Double = 0;
{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}
procedure Tftpframe.btnOpenClick(Sender: TObject);
begin
btnOpen.Enabled := false;
if IdFTP1.Connected then try
if TransferrignData then IdFTP1.Abort;
IdFTP1.Quit;
finally
CurrentDirEdit.Text := '/';
Directorylistbox.items.Clear;
SetFunctionButtons(false);
btnOpen.Caption := 'Connect';
btnOpen.Enabled := true;
btnOpen.Default := true;
end
else with IdFTP1 do try
idFTP1.User := ftpoption.EditUserName.Text;
IdFTP1.Password := ftpoption.Editpassword.Text;
IdFTP1.Host := ftpoption.edithostname.Text;
idftp1.Port := StrToIntDef(ftpoption.editport.text, 21);
IdFTP1.Passive := ftpoption.UsePassive.Checked;
Connect;
Self.ChageDir(CurrentDirEdit.Text);
SetFunctionButtons(true);
finally
btnOpen.Enabled := true;
end;
end;
procedure Tftpframe.btnOptionClick(Sender: TObject);
begin
ftpoption.show
end;
procedure Tftpframe.btnCloseClick(Sender: TObject);
begin
IdFTP1.Quit;
StatusBar2.Panels[1].Text := 'Disconnected.';
end;
procedure Tftpframe.IdLogDebug1LogItem(ASender: TComponent;
var AText: String);
begin
debuger.DebugListBox.ItemIndex := debuger.DebugListBox.Items.Add(AText);
end;
procedure Tftpframe.DebugClick(Sender: TObject);
begin
debuger.show;
end;
Procedure Tftpframe.SetFunctionButtons(AValue: Boolean);
Var
i: Integer;
begin
with CommandPanel do
for i := 0 to ControlCount - 1 do
if Controls[i].Name <> 'AbortButton' then Controls[i].Enabled := AValue;
with PopupMenu1 do
for i := 0 to Items.Count - 1 do Items[i].Enabled := AValue;
btnFTPchdir.Enabled := AValue;
btnmkdir.Enabled := AValue;
end;
procedure Tftpframe.btnuploadClick(Sender: TObject);
begin
if IdFTP1.Connected then begin
if UploadOpenDialog1.Execute then try
SetFunctionButtons(false);
IdFTP1.TransferType := ftBinary;
IdFTP1.Put(UploadOpenDialog1.FileName, ExtractFileName(UploadOpenDialog1.FileName));
ChageDir(idftp1.RetrieveCurrentDir);
finally
SetFunctionButtons(true);
end;
end;
end;
procedure Tftpframe.ChageDir(DirName: String);
begin
try
SetFunctionButtons(false);
IdFTP1.ChangeDir(DirName);
IdFTP1.TransferType := ftASCII;
CurrentDirEdit.Text := IdFTP1.RetrieveCurrentDir;
Directorylistbox.items.Clear;
IdFTP1.List(Directorylistbox.items);
finally
SetFunctionButtons(true);
end;
end;
procedure Tftpframe.btnFTPChDirClick(Sender: TObject);
begin
SetFunctionButtons(false);
ChageDir(CurrentDirEdit.Text);
SetFunctionButtons(true);
end;
function GetNameFromDirLine(Line: String; Var IsDirectory: Boolean): String;
Var
i: Integer;
DosListing: Boolean;
begin
IsDirectory := Line[1] = 'd';
DosListing := false;
for i := 0 to 7 do begin
if (i = 2) and not IsDirectory then begin
IsDirectory := Copy(Line, 1, Pos(' ', Line) - 1) = '<DIR>';
if not IsDirectory then
DosListing := Line[1] in ['0'..'9']
else DosListing := true;
end;
Delete(Line, 1, Pos(' ', Line));
While Line[1] = ' ' do Delete(Line, 1, 1);
if DosListing and (i = 2) then break;
end;
Result := Line;
end;
procedure Tftpframe.DirectoryListBoxDblClick(Sender: TObject);
Var
Name, Line: String;
IsDirectory: Boolean;
begin
if not IdFTP1.Connected then exit;
Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
Name := GetNameFromDirLine(Line, IsDirectory);
if IsDirectory then begin
SetFunctionButtons(false);
ChageDir(Name);
SetFunctionButtons(true);
end
else begin
try
SaveDialog1.FileName := Name;
if SaveDialog1.Execute then begin
SetFunctionButtons(false);
IdFTP1.TransferType := ftBinary;
BytesToTransfer := IdFTP1.Size(Name);
IdFTP1.Get(Name, SaveDialog1.FileName, true);
end;
finally
SetFunctionButtons(true);
end;
end;
end;
procedure Tftpframe.bntDeleteClick(Sender: TObject);
Var
Name, Line: String;
IsDirectory: Boolean;
begin
if not IdFTP1.Connected then exit;
Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
Name := GetNameFromDirLine(Line, IsDirectory);
if IsDirectory then try
SetFunctionButtons(false);
idftp1.RemoveDir(Name);
ChageDir(idftp1.RetrieveCurrentDir);
finally
end
else
try
SetFunctionButtons(false);
idftp1.Delete(Name);
ChageDir(idftp1.RetrieveCurrentDir);
finally
end;
end;
procedure Tftpframe.btnabortClick(Sender: TObject);
begin
AbortTransfer := true;
end;
procedure Tftpframe.btnbackClick(Sender: TObject);
begin
if not IdFTP1.Connected then exit;
try
ChageDir('..');
finally end;
end;
procedure Tftpframe.IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
const asStatusText: String);
begin
debuger.DebugListBox.ItemIndex := debuger.DebugListBox.Items.Add(asStatusText);
StatusBar2.Panels[1].Text := asStatusText;
end;
procedure Tftpframe.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
Var
S: String;
TotalTime: TDateTime;
H, M, Sec, MS: Word;
DLTime: Double;
begin
TotalTime := Now - STime;
DecodeTime(TotalTime, H, M, Sec, MS);
Sec := Sec + M * 60 + H * 3600;
DLTime := Sec + MS / 1000;
if DLTime > 0 then
AverageSpeed := (AWorkCount / 1024) / DLTime;
S := FormatFloat('0.00 KB/s', AverageSpeed);
case AWorkMode of
wmRead: StatusBar2.Panels[0].Text := 'Download speed ' + S;
wmWrite: StatusBar2.Panels[0].Text := 'Uploade speed ' + S;
end;
if AbortTransfer then IdFTP1.Abort;
ProgressBar1.Position := AWorkCount;
AbortTransfer := false;
end;
procedure Tftpframe.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
begin
TransferrignData := true;
btnAbort.Visible := true;
AbortTransfer := false;
STime := Now;
if AWorkCountMax > 0 then ProgressBar1.Max := AWorkCountMax
else ProgressBar1.Max := BytesToTransfer;
AverageSpeed := 0;
end;
procedure Tftpframe.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
btnabort.Visible := false;
StatusBar2.Panels[1].Text := 'Transfer complete.';
BytesToTransfer := 0;
TransferrignData := false;
ProgressBar1.Position := 0;
AverageSpeed := 0;
end;
procedure Tftpframe.btnmkdirClick(Sender: TObject);
Var
S: String;
begin
S := InputBox('Make new directory', 'Name', '');
if S <> '' then
try
SetFunctionButtons(false);
IdFTP1.MakeDir(S);
ChageDir(CurrentDirEdit.Text);
finally
SetFunctionButtons(true);
end;
end;
end. |