unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, wininet,
StdCtrls, ComCtrls, FileCtrl;
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
txtFTP: TEdit;
txtUsername: TEdit;
txtPassword: TEdit;
txtPath: TEdit;
CheckBox1: TCheckBox;
btnOpen: TButton;
btnList: TButton;
btnClose: TButton;
StatusBar1: TStatusBar;
ListBox1: TListBox;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
btnDownload: TButton;
RadioButton2: TRadioButton;
RadioButton1: TRadioButton;
btnUpload: TButton;
btnMkDir: TButton;
btnRmDir: TButton;
btnDelete: TButton;
btnRename: TButton;
procedure btnOpenClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btnListClick(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
procedure btnDownloadClick(Sender: TObject);
procedure FileListBox1Change(Sender: TObject);
procedure DriveComboBox1Change(Sender: TObject);
procedure DirectoryListBox1Change(Sender: TObject);
procedure FileListBox1Click(Sender: TObject);
procedure btnUploadClick(Sender: TObject);
procedure btnMkDirClick(Sender: TObject);
procedure btnRmDirClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure btnRenameClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
hInternet: pointer ;
hConnect: pointer ;
localDir: string ;
const
RootDot = '..' ;
implementation
{$R *.DFM}
function GetFTPDirectory(hConnect: pointer): string ;
var
dwDir: DWORD ;
Dir: array [0..255] of char ;
begin
dwDir := sizeof(Dir) ;
// FtpGetCurrentDirectory retrieves the current directory for the connection.
// returns True if successful
if FtpGetCurrentDirectory(hConnect, Dir, dwDir) Then
begin
if StrRScan(Dir, '/') + 1 = StrEnd(Dir) then
result := trim(StrPas(Dir))
else
result := trim(StrPas(Dir)) + '/' ;
end ;
end ;
procedure GetFTPDirectoryContents() ;
var
WFD: TWin32FindData ;
hFind: pointer ;
FTPPath: String;
begin
Form1.ListBox1.Clear ;
// Obtain the current FTP path
FTPPath := GetFTPDirectory(hConnect) ;
If FTPPath <> '/' Then Form1.ListBox1.Items.Add(RootDot) ;
FTPPath := FTPPath + '*.*' ;
if (hInternet <> nil) then
begin
if (hConnect <> nil) then
begin
// obtain the file handles via FtpFindFirstFile
// Search the first available file or directory
hFind := FtpFindFirstFile(hConnect,
pchar(FTPPath),
WFD,
INTERNET_FLAG_RELOAD OR INTERNET_FLAG_NO_CACHE_WRITE,
$0) ;
If (hFind <> nil) then
begin
repeat
If strLen(WFD.cFileName) > 0 Then
begin
If WFD.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
Form1.ListBox1.Items.Add(StrPas(WFD.cFileName) + '/')
else
Form1.ListBox1.Items.Add(strPas(WFD.cFileName)) ;
end ;
// Search the next available file or directory
until not InternetFindNextFile(hFind, @WFD) ;
// close file handle
InternetCloseHandle(hFind) ;
end ;
end ;
end ;
end ;
procedure TForm1.btnOpenClick(Sender: TObject);
var
FTPSite: String ;
begin
// Begin the FTP process by obtaining a handle to an internet session.
//
// INTERNET_OPEN_TYPE_DIRECT = 1; {direct to net}
// INTERNET_OPEN_TYPE_PROXY = 3; {via named proxy }
// INTERNET_FLAG_NO_CACHE_WRITE = $04000000; {don't write this item to the cache}
if CheckBox1.Checked = True then
hInternet := InternetOpen(pchar('FTP Application'),
INTERNET_OPEN_TYPE_PROXY,
nil,
nil,
INTERNET_FLAG_NO_CACHE_WRITE)
else
hInternet := InternetOpen(pchar('FTP Application'),
INTERNET_OPEN_TYPE_DIRECT,
nil,
nil,
INTERNET_FLAG_NO_CACHE_WRITE) ;
// If internet session created OK
if (hInternet <> nil) then
begin
FTPSite := txtFTP.Text ;
// 产生FTP service 的handle值?
//
// nServerPort: INTERNET_DEFAULT_FTP_PORT = 21
// FTP服务器的预设通讯端口(设定Internet服务的通讯端口)?
//
// dwService: INTERNET_SERVICE_FTP = 1
// FTP服务(设定Internet 服务类型)?
if (txtUsername.Text = '') and (txtPassword.Text = '') then
// anonymous
hConnect := InternetConnect(hInternet, pchar(FTPSite),
INTERNET_DEFAULT_FTP_PORT,
nil,
nil,
INTERNET_SERVICE_FTP,
INTERNET_FLAG_EXISTING_CONNECT OR INTERNET_FLAG_PASSIVE,
$0)
else
hConnect := InternetConnect(hInternet, pchar(FTPSite),
INTERNET_DEFAULT_FTP_PORT,
pchar(txtUsername.Text),
pchar(txtPassword.Text),
INTERNET_SERVICE_FTP,
INTERNET_FLAG_EXISTING_CONNECT OR INTERNET_FLAG_PASSIVE,
$0) ;
// If connection created OK
If (hConnect <> nil) Then
begin
// Get Current Directory
txtPath.Text := GetFTPDirectory(hConnect) ;
btnOpen.Enabled := False ;
btnList.Enabled := True ;
btnClose.Enabled := True ;
if (txtUsername.Text = '') and (txtPassword.Text = '') then
StatusBar1.Panels[0].Text := 'FTP Connection Opened - anonymous'
else
StatusBar1.Panels[0].Text := 'FTP Connection Opened - ' + txtUsername.Text ;
end
else
begin
btnOpen.Enabled := True ;
btnList.Enabled := False ;
btnClose.Enabled := False ;
StatusBar1.Panels[0].Text := 'Error: Can not create Connection Session.' ;
end ;
end
else
begin
btnOpen.Enabled := True ;
btnList.Enabled := False ;
btnClose.Enabled := False ;
StatusBar1.Panels[0].Text := 'Error: Can not create Internet Session.' ;
end ;
end;
procedure TForm1.btnCloseClick(Sender: TObject);
begin
// close internet service connection
if (hConnect <> nil) then
begin
InternetCloseHandle(hConnect) ;
hConnect := nil ;
StatusBar1.Panels[0].Text := 'Internet Service Closed.' ;
end ;
// close internet session
if (hInternet <> nil) then
begin
InternetCloseHandle(hInternet) ;
hInternet := nil ;
StatusBar1.Panels[0].Text := 'Internet Connection Closed.' ;
end ;
btnOpen.Enabled := True ;
btnList.Enabled := False ;
btnClose.Enabled := False ;
btnDownload.Enabled := False ;
btnUpload.Enabled := False ;
StatusBar1.Panels[0].Text := 'FTP connection closed.' ;
txtPath.Text := '' ;
ListBox1.Clear ;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
btnOpen.Enabled := True ;
btnList.Enabled := False ;
btnClose.Enabled := False ;
btnDownload.Enabled := False ;
btnUpload.Enabled := False ;
ListBox1.Clear ;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// close internet service connection
if (hConnect <> nil) then
begin
InternetCloseHandle(hConnect) ;
hConnect := nil ;
end ;
// close internet session
if (hInternet <> nil) then
begin
InternetCloseHandle(hInternet) ;
hInternet := nil ;
end ;
application.Terminate ;
end;
procedure TForm1.btnListClick(Sender: TObject);
begin
GetFTPDirectoryContents();
btnOpen.Enabled := False ;
btnList.Enabled := True ;
btnClose.Enabled := True ;
btnDownload.Enabled := True ;
btnUpload.Enabled := True ;
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
NewPath: String ;
FTPPath: String ;
i: integer ;
begin
for i := 0 to (ListBox1.Items.Count - 1) do
begin
if ListBox1.Selected then
NewPath := ListBox1.items.Strings
end;
If (NewPath <> RootDot) And (StrRScan(pchar(NewPath), '/') + 1 <> StrEnd(pchar(NewPath))) Then
exit
else
begin
ListBox1.Clear ;
FTPPath := GetFTPDirectory(hConnect) ;
if StrRScan(pchar(FTPPath), '/') + 1 = StrEnd(pchar(FTPPath)) then
FTPPath := trim(FTPPath) + NewPath
else
FTPPath := trim(FTPPath) + NewPath + '/' ;
// set the new path using the API
FtpSetCurrentDirectory(hConnect, pchar(FTPPath)) ;
// reflect the new path in the text box
txtPath.Text := GetFTPDirectory(hConnect) ;
// reload the list with the current directory
GetFTPDirectoryContents();
end ;
end ;
//
// Download File from FTP server to local directory
//
procedure TForm1.btnDownloadClick(Sender: TObject);
var
RemoteFile: String ;
LocalFile: String ;
sFile: String ;
FTPPath: String ;
i: integer ;
blnReturn: boolean ;
dwInternetFlags: DWORD ;
begin
if (hConnect <> nil) then
begin
FTPPath := GetFTPDirectory(hConnect) ;
for i := 0 to (ListBox1.Items.Count - 1) do
begin
if ListBox1.Selected then
sFile := ListBox1.items.Strings
end;
If (sFile = '') or (sFile = RootDot) or (StrRScan(pchar(sFile), '/') + 1 = StrEnd(pchar(sFile))) Then
exit
else
begin
// FTP Remote file name
RemoteFile := FTPPath + sFile ;
// Local file name
LocalFile := localDir + sFile ;
StatusBar1.Panels[0].Text := 'Downloading' ;
// FILE_ATTRIBUTE_ARCHIVE = $00000020;
// FTP_TRANSFER_TYPE_UNKNOWN = $00000000;
// FTP download (get)
if RadioButton1.Checked then
dwInternetFlags := FTP_TRANSFER_TYPE_BINARY
else
dwInternetFlags := FTP_TRANSFER_TYPE_ASCII ;
blnReturn := FtpGetFile(hConnect,
pchar(RemoteFile),
pchar(LocalFile),
False,
FILE_ATTRIBUTE_ARCHIVE,
dwInternetFlags,
$0) ;
If blnReturn then
begin
// Download successfully
StatusBar1.Panels[0].Text := 'Downloaded successfully.' ;
ShowMessage('Downloaded successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Downloaded error.' ;
ShowMessage('Downloaded error.');
end ;
FileListBox1.Update ;
end ;
end ;
end;
procedure TForm1.FileListBox1Change(Sender: TObject);
begin
FileListBox1.Refresh ;
end;
procedure TForm1.DriveComboBox1Change(Sender: TObject);
begin
localDir := DriveComboBox1.Drive + ':/' ;
StatusBar1.Panels[0].Text := 'Local Drive: ' + localDir ;
DirectoryListBox1.OnChange(nil) ;
end;
procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
If (StrRScan(pchar(DirectoryListBox1.Directory), '/') + 1 <>
StrEnd(pchar(DirectoryListBox1.Directory))) Then
localDir := DirectoryListBox1.Directory + '/'
else
localDir := DirectoryListBox1.Directory ;
StatusBar1.Panels[0].Text := 'Local Directory: ' + localDir ;
end;
procedure TForm1.FileListBox1Click(Sender: TObject);
begin
StatusBar1.Panels[0].Text := 'Local File: ' + FileListBox1.FileName ;
end;
//
// Upload File from local directory to FTP server
//
procedure TForm1.btnUploadClick(Sender: TObject);
var
RemoteFile: String ;
LocalFile: String ;
sFile: String ;
FTPPath: String ;
i: integer ;
blnReturn: boolean ;
dwInternetFlags: DWORD ;
begin
if (hConnect <> nil) then
begin
FTPPath := GetFTPDirectory(hConnect) ;
for i := 0 to (FileListBox1.Items.Count - 1) do
begin
if FileListBox1.Selected then
sFile := FileListBox1.Items.Strings
end;
If (sFile = '') Then
exit
else
begin
// Local file name
LocalFile := localDir + sFile ;
// FTP Remote file name
RemoteFile := FTPPath + sFile ;
StatusBar1.Panels[0].Text := 'Uploading' ;
// FILE_ATTRIBUTE_ARCHIVE = $00000020;
// FTP upload (put)
if RadioButton1.Checked then
dwInternetFlags := FTP_TRANSFER_TYPE_BINARY
else
dwInternetFlags := FTP_TRANSFER_TYPE_ASCII ;
blnReturn := FtpPutFile(hConnect,
pchar(LocalFile),
pchar(RemoteFile),
dwInternetFlags,
$0) ;
If blnReturn then
begin
// Download successfully
StatusBar1.Panels[0].Text := 'Uploaded successfully.' ;
ShowMessage('Uploaded successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Uploaded error.' ;
ShowMessage('Uploaded error.');
end ;
GetFTPDirectoryContents();
ListBox1.Update ;
end ;
end ;
end;
procedure TForm1.btnMkDirClick(Sender: TObject);
var
RemoteDir: string;
blnReturn: boolean ;
begin
if (hConnect <> nil) then
begin
RemoteDir := InputBox('FTP Create Directory', 'Enter a new remote directory: ', '');
If (RemoteDir = '') Then
exit
else
begin
// Create a FTP Remote Directory
blnReturn := FtpCreateDirectory(hConnect, pchar(RemoteDir)) ;
StatusBar1.Panels[0].Text := 'Making a new FTP directory' ;
If blnReturn then
begin
// Create Directory successfully
StatusBar1.Panels[0].Text := 'Created directory successfully.' ;
ShowMessage('Created directory successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Created directory error.' ;
ShowMessage('Created directory error.');
end ;
GetFTPDirectoryContents();
ListBox1.Update ;
end ;
end ;
end;
procedure TForm1.btnRmDirClick(Sender: TObject);
var
RemoteDir: string;
FTPPath: String ;
blnReturn: boolean ;
i: integer;
begin
for i := 0 to (ListBox1.Items.Count - 1) do
begin
if ListBox1.Selected then
RemoteDir := ListBox1.items.Strings
end;
If (RemoteDir = '') or (StrRScan(pchar(RemoteDir), '/') + 1 <> StrEnd(pchar(RemoteDir))) Then
exit
else
begin
if (hConnect <> nil) then
begin
FTPPath := GetFTPDirectory(hConnect) ;
Delete(RemoteDir, Length(RemoteDir), 1);
// Remove a FTP Remote Directory
RemoteDir := FTPPath + RemoteDir ;
blnReturn := FtpRemoveDirectory(hConnect, pchar(RemoteDir)) ;
StatusBar1.Panels[0].Text := 'Removing a FTP directory' ;
If blnReturn then
begin
// Remove Directory successfully
StatusBar1.Panels[0].Text := 'Removed directory successfully.' ;
ShowMessage('Removed directory successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Removed directory error.' ;
ShowMessage('Removed directory error.');
end ;
GetFTPDirectoryContents();
ListBox1.Update ;
end ;
end ;
end;
procedure TForm1.btnDeleteClick(Sender: TObject);
var
RemoteFile: string;
FTPPath: String ;
blnReturn: boolean ;
i: integer;
begin
for i := 0 to (ListBox1.Items.Count - 1) do
begin
if ListBox1.Selected then
RemoteFile := ListBox1.items.Strings
end;
If (RemoteFile = '') or
(RemoteFile = RootDot) or
(StrRScan(pchar(RemoteFile), '/') + 1 = StrEnd(pchar(RemoteFile))) Then
exit
else
begin
if (hConnect <> nil) then
begin
FTPPath := GetFTPDirectory(hConnect) ;
// Remove a FTP Remote Directory
RemoteFile := FTPPath + RemoteFile ;
blnReturn := FtpDeleteFile(hConnect, pchar(RemoteFile)) ;
StatusBar1.Panels[0].Text := 'Removing a FTP file' ;
If blnReturn then
begin
// Remove file successfully
StatusBar1.Panels[0].Text := 'Removed file successfully.' ;
ShowMessage('Removed file successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Removed file error.' ;
ShowMessage('Removed file error.');
end ;
GetFTPDirectoryContents();
ListBox1.Update ;
end ;
end ;
end;
procedure TForm1.btnRenameClick(Sender: TObject);
var
RemoteOldFile: string;
RemoteNewFile: string;
FTPPath: String ;
blnReturn: boolean ;
i: integer;
begin
for i := 0 to (ListBox1.Items.Count - 1) do
begin
if ListBox1.Selected then
RemoteOldFile := ListBox1.items.Strings
end;
If (RemoteOldFile = '') or
(RemoteOldFile = RootDot) or
(StrRScan(pchar(RemoteOldFile), '/') + 1 = StrEnd(pchar(RemoteOldFile))) Then
exit
else
begin
RemoteNewFile := InputBox('FTP Rename File',
'Enter a new remote file name for ' + RemoteOldFile + ': ', '');
If (RemoteNewFile = '') Then exit ;
if (hConnect <> nil) then
begin
FTPPath := GetFTPDirectory(hConnect) ;
RemoteOldFile := FTPPath + RemoteOldFile ;
RemoteNewFile := FTPPath + RemoteNewFile ;
// Remove a FTP Remote Directory
blnReturn := FtpRenameFile(hConnect,
pchar(RemoteOldFile),
pchar(RemoteNewFile)) ;
StatusBar1.Panels[0].Text := 'Renaming a FTP file' ;
If blnReturn then
begin
// Rename file successfully
StatusBar1.Panels[0].Text := 'Renamed file successfully.' ;
ShowMessage('Renamed file successfully.');
end
else
begin
// Error
StatusBar1.Panels[0].Text := 'Renamed file error.' ;
ShowMessage('Renamed file error.');
end ;
GetFTPDirectoryContents();
ListBox1.Update ;
end ;
end ;
end;
end.