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 &lt;= 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) &gt; 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 = '&lt;DIR&gt;') and (plik_nazwa &lt;&gt; '.') and (plik_nazwa &lt;&gt; '..') 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 &lt;&gt; '&lt;DIR&gt;' 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 &lt;&gt; '\' then
      begin
        //jeżeli katalog
        if (test_kat = '&lt;DIR&gt;') and (plik_nazwa &lt;&gt; '.') 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 &lt;&gt; '&lt;DIR&gt;' 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;

6 komentarzy

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 ...