IdFTP i IdFTPServer - podstawowe procedury
rk7771
INDY - Internet Direct (komponenty otwarte)
Przedstawiam najważniejsze procedury potrzebne do zbudowania
programu zawierającego komponenty IdFTP (klient) i IdFTPServer.
Dodatkowo dodałem procedury obsługi wyświetalania i zmiany katalogów
w ListView.
Niektóre zmienne pochodzą z mojego programu, który pracuje jako P2P.
Miłej lektury.
Serwer:
procedure Tform.IdFTPServer1AfterUserLogin(ASender: TIdFTPServerThread);
begin
//ustawiamy katalog domowy podczas logowania
//jak np.: poniżej
ASender.HomeDir := '\';
ASender.CurrentDir := '\';
//użycie własnych zmiennych
appdir := sc_programu:=ExtractFilePath(ParamStr(0));
end;
procedure Tform.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
const AUsername, APassword: string; var AAuthenticated: Boolean);
begin
//sprawdzenie użytkownika
AAuthenticated := ((AUsername = 'ktos') and (APassword = 'haslo'));
if AAuthenticated = true then
begin
//funkcje po rozpoznaniu użytkownika
end;
end;
procedure Tform.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
const AFileName: string; AAppend: Boolean; var VStream: TStream);
begin
//procedura odpowiedzialna za odbieranie pliku
if not Aappend then
begin
//odbieranie pliku - nowy plik
VStream := TFileStream.Create(AppDir + AFilename,fmCreate);
end;
if Aappend then
begin
//odbieranie pliku - nadpisywanie istniejącego
VStream := TFileStream.Create(AppDir + AFilename,fmOpenWrite);
end;
end;
procedure Tform.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
const AFileName: string; var VStream: TStream);
begin
//wysyłanie pliku
VStream := TFileStream.Create(AppDir + AFilename,fmOpenRead);
Application.ProcessMessages;
end;
procedure Tform.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: string);
begin
//zmiana katalogu
Asender.CurrentDir := VDirectory;
//własna zmienna
change_dir := VDirectory;
end;
procedure Tform.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
const APath: string; ADirectoryListing: TIdFTPListItems);
var
LFTPItem :TIdFTPListItem;
SR : TSearchRec;
SRI : Integer;
begin
//przesłania zawartości katalogu do klienta
//ADirectoryListing.DirFormat := doUnix;
SRI := FindFirst(AppDir + change_dir + '*.*', faAnyFile - faHidden - faSysFile, SR);
While SRI = 0 do
begin
LFTPItem := ADirectoryListing.Add;
LFTPItem.FileName := SR.Name;
LFTPItem.Size := SR.Size;
LFTPItem.ModifiedDate := FileDateToDateTime(SR.Time);
Application.ProcessMessages;
if SR.Attr = faDirectory then
LFTPItem.ItemType := ditDirectory
else
LFTPItem.ItemType := ditFile;
SRI := FindNext(SR);
end;
FindClose(SR);
SetCurrentDir(AppDir + '..');
end;
procedure Tform.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
var VDirectory: string);
begin
//tworzenie katalogu
if not ForceDirectories(Appdir + VDirectory) then
begin
//można dodać komunikat błędu na serwerze
//najlepiej z zapisem do logu, a nie jak poniżej pokazuje przykład
//Raise Exception.Create('Błąd tworzenia katalogu');
end;
end;
Klient:
procedure Tform.IdTCPClient1Status(ASender: TObject;
const AStatus: TIdStatus; const AStatusText: string);
begin
//procedura sprawdza status połączenia klienta
//i tak np.:
if AstatusText = 'Connected.' then
begin
//połączony
end;
if AstatusText = 'Disconnecting.' then
begin
//Rozłączony
end;
end;
//połączenie
procedure Tform.sbtn_polaczClick(Sender: TObject);
var
kontrolka : integer;
begin
kontrolka := 0;
if (Edit_adres.Text = '') then
begin
showmessage('Podaj adres IP adresata w sieci TCP/IP !!!');
end;
if Edit_adres.Text = '127.0.0.1' then
begin
Showmessage('Połączenie z adresem 127.0.0.1 nie jest obsługiwane !!!');
end;
try
if (Edit_adres.Text <> '') and (Edit_adres.Text <> '127.0.0.1') and (kontrolka = 0) then
begin
IdFTP1.Username := 'ktos';
IdFTP1.Password := 'haslo';
IdFTP1.Host := Edit_adres.Text;
if not IdFTP1.Connected then
begin
IdFTP1.Connect();
if IdFTP1.Connected then
begin
ListView_zdalny.Clear;
kat_zdalny := IdFTP1.RetrieveCurrentDir;
kat_zdalny_bezwzgledny := IdFTP1.RetrieveCurrentDir;
edit_kat_zdalny.Text := kat_zdalny;
ListView_kat_zdalny();
sbtn_polacz.Caption := 'Rozłącz';
tele_form.status_ftp := 1;
kontrolka := 1;
end;
end;
end;
except
on exception do
begin
showmessage('Nie można nawiązać połączenia FTP !!!'
+ #13 + 'Adres: ' + Edit_adres.Text + ' nieodpowiada.');
end;
end;
try
if (Edit_adres.Text <> '') and (kontrolka = 0) then
begin
IdFTP1.Username := 'ktos';
IdFTP1.Password := 'haslo';
IdFTP1.Host := Edit_adres.Text;
if not IdFTP1.Connected then
begin
IdFTP1.Connect();
end;
if IdFTP1.Connected then
begin
IdFTP1.Disconnect;
ListView_zdalny.Clear;
sbtn_polacz.Caption := 'Połącz';
tele_form.status_ftp := 0;
kontrolka := 1;
end;
end;
except
on exception do
begin
showmessage('Nie można wysłać informacji o zakończeniu połączenia FTP !!!'
+ #13 + 'Adres: ' + Edit_adres.Text + ' nieodpowiada.');
end;
end;
end;
//wysłanie pliku
procedure Tform.sbtn_wyslijClick(Sender: TObject);
var
kontrolka : Integer;
File_lokalny : String;
localfile : string;
remotefile : string;
begin
Kontrolka:=ListView_lokalny.SelCount;
try
// jezeli puste pole to index = 0, jezeli pozycja wybrana to index = 1
if kontrolka <> 0 then
begin
File_lokalny := ListView_lokalny.Selected.Caption;
if directoryexists(Edit_kat_lokalny.Text + File_lokalny + '\') then
begin
showmessage('Przesyłanie katalogu nie jest możliwe !!!');
end;
if fileexists(Edit_kat_lokalny.Text + File_lokalny) then
begin
if IdFTP1.Connected then
begin
IdFTP1.TransferType := ftBinary;
//IdFTP1.ChangeDir('\');
localfile := Edit_kat_lokalny.Text + File_lokalny;
remotefile := File_lokalny;
IdFTP1.Put(LocalFile, RemoteFile);
ListView_kat_zdalny();
end;
end;
end;
except
on exception do
begin
showmessage('Błąd podczas wysyłania pliku !!!'
+ #13 + 'Nie można nawiązać połączenia FTP !!!'
+ #13 + 'Adres: ' + IdFTP1.Host + ' nieodpowiada.');
end;
end;
end;
//pobieranie pliku
procedure Tftp_form.sbtn_pobierzClick(Sender: TObject);
var
kontrolka : Integer;
File_zdalny : String;
test : string;
localfile : string;
remotefile : string;
begin
Kontrolka:=ListView_zdalny.SelCount;
try
// jezeli puste pole to index = 0, jezeli pozycja wybrana to index = 1
if kontrolka <> 0 then
begin
File_zdalny := ListView_zdalny.Selected.Caption;
test := ListView_zdalny.Selected.SubItems[0];
if test = 'Dir' then
begin
showmessage('Pobranie katalogu nie jest możliwe !!!');
end;
if test <> 'Dir' then
begin
if IdFTP1.Connected then
begin
IdFTP1.TransferType := ftBinary;
//IdFTP1.ChangeDir('\');
localfile := Edit_kat_lokalny.Text + File_zdalny;
remotefile := File_zdalny;
if fileexists(Edit_kat_lokalny.Text + File_zdalny) then
begin
showmessage('Pobieranie przerwane !!!' + #13 + 'Pobierany plik istnieje już na dysku lokalnym !!!');
end;
if not fileexists(Edit_kat_lokalny.Text + File_zdalny) then
begin
IdFTP1.get(RemoteFile, LocalFile);
ListView_kat_lokalny();
end;
end;
end;
end;
except
on exception do
begin
showmessage('Błąd podczas pobierania pliku !!!'
+ #13 + 'Nie można nawiązać połączenia FTP !!!'
+ #13 + 'Adres: ' + IdFTP1.Host + ' nieodpowiada.');
end;
end;
end;
//wyzerowanie paska postępu
procedure Tform.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
begin
ProgressBar1.Max := AWorkCountMax;
ProgressBar1.Position := 0;
Application.ProcessMessages;
end;
//pokazanie postępu na pasku
procedure Tform.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
begin
ProgressBar1.Position := AWorkCount;
Application.ProcessMessages;
end;
//wyzerowanie paska postępu na zakończenie pracy klienta
procedure Tftp_form.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
ProgressBar1.Position := 0;
Application.ProcessMessages;
end;
//Zmiana katalogu lokalnego w ListView
procedure Tform.ListView_lokalnyDblClick(Sender: TObject);
var
kontrolka_prawa : integer;
plik_nazwa : string;
plik_rozsz : string;
plik_wielk : string;
plik_data : string;
dir_prawa : string;
dir_prawa_test : string;
znak_prawa : string;
begin
dir_prawa := '';
dir_prawa_test := '';
znak_prawa := '';
ListView_lokalny.SetFocus;
ListView_lokalny.ShowWorkAreas:=true;
ListView_lokalny.RowSelect:=true; // aby zaznaczać ca-y wiersz
kontrolka_prawa:=ListView_lokalny.SelCount;
// jezeli puste pole to index = 0, jezeli pozycja wybrana to index = 1
if (kontrolka_prawa = 0) then
begin
showmessage('Dokonaj wyboru pliku lub katalogu na dysku lokalnym ...');
end;
if (ListView_lokalny.ItemFocused <> nil) and (kontrolka_prawa <> 0) then
begin
plik_nazwa := ListView_lokalny.Selected.Caption;
plik_wielk := ListView_lokalny.Selected.SubItems.Strings[0];
plik_data := ListView_lokalny.Selected.SubItems.Strings[1];
//usunięcie z nazwy znaków klamry tj.: "[" oraz "]"
while (pos('[', plik_nazwa) > 0) and (plik_wielk = 'Dir') do
begin
delete(plik_nazwa, pos('[', plik_nazwa), 1);
end;
while (pos(']', plik_nazwa) > 0) and (plik_wielk = 'Dir') do
begin
delete(plik_nazwa, pos(']', plik_nazwa), 1);
end;
plik_rozsz := ExtractFileExt(plik_nazwa);
//zmiana katalogu na podkatalog
if (plik_nazwa <> '..') and (plik_wielk = 'Dir') then
begin
if directoryexists(Edit_kat_lokalny.Text + plik_nazwa + '\') then
begin
chdir(pchar(Edit_kat_lokalny.Text + plik_nazwa + '\'));
Edit_kat_lokalny.Text := Edit_kat_lokalny.Text + plik_nazwa + '\';
//odťwieżanie zawartości prawego okna ...
tele_form.kat_lokalny := Edit_kat_lokalny.Text;
ListView_kat_lokalny();
end;
end;
//zmiana katalogu na katalog nadrzedny [..]
if (plik_nazwa = '..') and (plik_wielk = 'Dir') then
begin
dir_prawa := Edit_kat_lokalny.Text;
dir_prawa_test := dir_prawa;
if directoryexists(dir_prawa_test) and (length(Dir_prawa_test) > 3) then
begin
znak_prawa:=copy(Dir_prawa_test, length(Dir_prawa_test), 1);
if znak_prawa = '\' then
begin
delete(Dir_prawa_test,length(Dir_prawa_test), 1);
znak_prawa:=copy(Dir_prawa_test, length(Dir_prawa_test), 1);
while (znak_prawa <> '\') do
begin
delete(Dir_prawa_test,length(Dir_prawa_test), 1);
znak_prawa:=copy(Dir_prawa_test, length(Dir_prawa_test), 1);
end;
if znak_prawa = '\' then
begin
Dir_prawa:=Dir_prawa_test;
Edit_kat_lokalny.Text := Dir_prawa;
tele_form.kat_lokalny := Edit_kat_lokalny.Text;
ListView_kat_lokalny();
end;
end;
end;
end;
end;
end;
//Zmiana katalogu zdalnego w ListView
procedure Tform.ListView_zdalnyDblClick(Sender: TObject);
var
kontrolka_lewa : integer;
plik_nazwa : string;
plik_rozsz : string;
plik_wielk : string;
dir_lewa : string;
dir_lewa_test : string;
znak_lewa : string;
begin
dir_lewa := '';
dir_lewa_test := '';
znak_lewa := '';
ListView_zdalny.SetFocus;
ListView_zdalny.ShowWorkAreas:=true;
ListView_zdalny.RowSelect:=true; // aby zaznaczaŠ ca-y wiersz
kontrolka_lewa:=ListView_zdalny.SelCount;
// jezeli puste pole to index = 0, jezeli pozycja wybrana to index = 1
if (kontrolka_lewa = 0) then
begin
showmessage('Dokonaj wyboru pliku lub katalogu na dysku zdalnym ...');
end;
if (ListView_zdalny.ItemFocused <> nil) and (kontrolka_lewa <> 0) then
begin
plik_nazwa := ListView_zdalny.Selected.Caption;
plik_wielk := ListView_zdalny.Selected.SubItems.Strings[0];
//usunięcie z nazwy znaków klamry tj.: "[" oraz "]"
while (pos('[', plik_nazwa) > 0) and (plik_wielk = 'Dir') do
begin
delete(plik_nazwa, pos('[', plik_nazwa), 1);
end;
while (pos(']', plik_nazwa) > 0) and (plik_wielk = 'Dir') do
begin
delete(plik_nazwa, pos(']', plik_nazwa), 1);
end;
plik_rozsz := ExtractFileExt(plik_nazwa);
//zmiana katalogu na podkatalog
if (plik_nazwa <> '..') and (plik_wielk = 'Dir') then
begin
tele_form.kat_zdalny := tele_form.kat_zdalny + plik_nazwa + '\';
ListView_kat_zdalny();
Edit_kat_zdalny.Text := tele_form.kat_zdalny;
end;
//zmiana katalogu na katalog nadrzedny [..]
if (plik_nazwa = '..') and (plik_wielk = 'Dir') then
begin
dir_lewa := Edit_kat_zdalny.Text;
dir_lewa_test := dir_lewa;
if length(Dir_lewa_test) > 1 then
begin
znak_lewa:=copy(Dir_lewa_test, length(Dir_lewa_test), 1);
if znak_lewa = '\' then
begin
delete(Dir_lewa_test,length(Dir_lewa_test), 1);
znak_lewa:=copy(Dir_lewa_test, length(Dir_lewa_test), 1);
while (znak_lewa <> '\') do
begin
delete(Dir_lewa_test,length(Dir_lewa_test), 1);
znak_lewa:=copy(Dir_lewa_test, length(Dir_lewa_test), 1);
end;
if znak_lewa = '\' then
begin
Dir_lewa:=Dir_lewa_test;
Edit_kat_zdalny.Text := Dir_lewa;
tele_form.kat_zdalny := Edit_kat_zdalny.Text;
ListView_kat_zdalny();
end;
end;
end;
end;
end;
end;
//Utworzenie katalogu lokalnego
procedure Tform.sbtn_utw_kat_lokalnyClick(Sender: TObject);
var
nowy_kat : string;
begin
nowy_kat := InputBox('Podaj nazwę katalogu!', 'Wprowadź nazwę:', '');
if nowy_kat <> '' then
begin
chdir(pchar(Edit_kat_lokalny.Text));
mkdir(pchar(nowy_kat));
ListView_kat_lokalny();
end;
end;
//Utworzenie katalogu zdalnego
procedure Tform.sbtn_utw_kat_zdalnyClick(Sender: TObject);
var
nowy_kat : string;
begin
nowy_kat := InputBox('Podaj nazwę katalogu!', 'Wprowadź nazwę:', '');
if nowy_kat <> '' then
begin
IdFTP1.MakeDir(nowy_kat);
ListView_kat_zdalny();
end;
end;
Zawartość katalogów w ListView - zdalny i lokalny
//Wyświetlenie zawartości serwera w listview
procedure Tftp_form.ListView_kat_zdalny();
Var
LS: TStringList;
ind : integer;
List_zdalny : TListItem;
test_kat : string;
plik_nazwa : string;
plik_wielk : string;
plik_data : string;
begin
LS := TStringList.Create;
try
//IdFTP1.ChangeDir('\');
IdFTP1.ChangeDir(tele_form.kat_zdalny);
IdFTP1.TransferType := ftASCII;
ListBox1.Items.Clear;
IdFTP1.List(LS);
LS.Sort;
LS.Capacity;
ListBox1.Items.Assign(LS);
ind := 0;
ListBox1.Selected[ind] := true;
ListView_zdalny.Clear;
while ind + 1 <= LS.Count do // rob dopoki liczba zbalezionych plikow nie wyjdzie poza zakres indeksu
begin
test_kat := copy(ListBox1.Items.Strings[ind], 24, 5);
plik_nazwa := copy(ListBox1.Items.Strings[ind], 40, length(ListBox1.Items.ValueFromIndex[ind]));
plik_wielk := copy(ListBox1.Items.Strings[ind], 28, 10);
while pos(' ', plik_wielk) > 0 do
begin
delete(plik_wielk, 1, pos(' ', plik_wielk));
end;
plik_data := copy(ListBox1.Items.Strings[ind], 1, 23);
//jeżeli główna ścieżka
if tele_form.kat_zdalny = '\' then
begin
//jeżeli katalog
if (test_kat = '<DIR>') and (plik_nazwa <> '.') and (plik_nazwa <> '..') then
begin
List_zdalny := ListView_zdalny.Items.Add; // stworzenie nowej pozycji
List_zdalny.Caption := '[' + plik_nazwa + ']';
List_zdalny.SubItems.Add('Dir');
end;
//jeżeli plik
if test_kat <> '<DIR>' then
begin
List_zdalny := ListView_zdalny.Items.Add; // stworzenie nowej pozycji
List_zdalny.Caption := plik_nazwa;
List_zdalny.SubItems.Add(plik_wielk);
List_zdalny.SubItems.Add(plik_data);
end;
end;
//jeżeli ścieżka podrzędna
if tele_form.kat_zdalny <> '\' then
begin
//jeżeli katalog
if (test_kat = '<DIR>') and (plik_nazwa <> '.') then
begin
List_zdalny := ListView_zdalny.Items.Add; // stworzenie nowej pozycji
List_zdalny.Caption := '[' + plik_nazwa + ']';
List_zdalny.SubItems.Add('Dir');
end;
//jeżeli plik
if test_kat <> '<DIR>' then
begin
List_zdalny := ListView_zdalny.Items.Add; // stworzenie nowej pozycji
List_zdalny.Caption := plik_nazwa;
List_zdalny.SubItems.Add(plik_wielk);
List_zdalny.SubItems.Add(plik_data);
end;
end;
ind := ind +1;
if ind + 1 > LS.Count then
begin
break;
end;
ListBox1.Selected[ind] := true;
end;
finally
LS.Free;
end;
end;
//wyświetelenie zawartości katalogu lokalnego w ListView
procedure Tftp_form.ListView_kat_lokalny();
var
SRKat_lokalny : TSearchRec; // rekord
SRKat_lokalny_test : string;
ListKat_lokalny : TListItem; // pozycja w ListView
FoundKat_lokalny : Integer; // zmienna oznacza ilosc znalezionych plikow
maskaKat_lokalny : string;
DirKat_lokalny : string;
begin
sc_programu:=ExtractFilePath(ParamStr(0));
//ListView_lokalny.SetFocus;
ListView_lokalny.ShowWorkAreas:=true;
ListView_lokalny.RowSelect:=true; // aby zaznaczać cały wiersz
ListView_lokalny.Items.Clear; // wyczyszczenie komponentu
maskaKat_lokalny := '*.*';
DirKat_lokalny := tele_form.kat_lokalny;
FoundKat_lokalny := FindFirst( DirKat_lokalny + maskaKat_lokalny, faAnyFile, SRKat_lokalny ); // odnajdź pliki
while ( FoundKat_lokalny = 0 ) do // rob dopoki liczba zbalezionych plikow nie rowna sie zero
begin
//jeżeli nie jest to '.' i jest katalogiem (plik nieistnieje)
if (SRKat_lokalny.Name <> '.') and not (FileExists (DirKat_lokalny + SRKat_lokalny.Name)) then
begin
ListKat_lokalny := ListView_lokalny.Items.Add; // stworz nowa pozycje
ListKat_lokalny.Caption := '[' + SRKat_lokalny.Name + ']'; // ustaw pozycje
ListKat_lokalny.SubItems.Add('Dir'); // jeżeli katalog to bez rozszerzenia
ListKat_lokalny.SubItems.Add(DateTimeToStr(FileDateToDateTime(SRKat_lokalny.Time)));
end;
// jeżeli nie jest to '.' i nie jest to katalog
if (SRKat_lokalny.Name <> '.') and (FileExists (DirKat_lokalny + SRKat_lokalny.Name)) then
begin
ListKat_lokalny := ListView_lokalny.Items.Add; // stworz nowa pozycje
SRKat_lokalny_test := ExtractFileName(SRKat_lokalny.Name);
ListKat_lokalny.Caption := SRKat_lokalny_test; // nazwa pliku ustaw pozycje
ListKat_lokalny.SubItems.Add(IntToStr(SRKat_lokalny.Size)); // dodaj rozmiar pliku
ListKat_lokalny.SubItems.Add(DateTimeToStr(FileDateToDateTime(SRKat_lokalny.Time)));
end;
// --
FoundKat_lokalny := FindNext(SRKat_lokalny); // kontynuuj przeszukiwanie
end;
FindClose(SRKat_lokalny); // zkaoncz przeszukiwanie
end;
Edit_kat_lokalny.Text := DirKat_lokalny;
end;
gdzie tu jest jakiś załącznik??
Do dupy z taką robotą i tak nie wiem jak postawić ftp na kompie :/
Weź kod źródłowy w znacznik
Załącznik zawiera wersję procedur w pliku tekstowym.
Poprawiłem końcówkę - znaczniki HTML "<" i ">" powodowały mały "miszmasz". Teraz powinno być lepiej widoczne.
Koncówka się trochę rozjechała, ale to już nie jest moja wina ...
... może zbyt duża ilość tekstu ...