[Delphi] FTP Manager 1.0

Iniciado por BigBear, 6 Agosto 2016, 04:01 AM

0 Miembros y 1 Visitante están viendo este tema.

BigBear

Un cliente FTP en Delphi con las siguientes opciones :

  • Se puede conectar a cualquier servidor FTP
  • Navegar y listar los directorios de nuestra computadora
  • Navegar y listar los directorios del servidor FTP
  • Se puede crear,renombrar,eliminar archivos y directorios de nuestra computadora
  • Se puede crear,renombrar,eliminar archivos y directorios del servidor FTP
  • Se puede bajar y subir archivos del servidor FTP comodamente

    Una imagen :



    El codigo :

    Código (delphi) [Seleccionar]

    // FTP Manager 1.0
    // (C) Doddy Hackman 2016

    unit ftp;

    interface

    uses
      Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
      System.Classes, Vcl.Graphics,
      Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,
      IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
      IdExplicitTLSClientServerBase, IdFTP, Shellapi, Vcl.ImgList, IdFTPList,
      Vcl.Imaging.pngimage, Vcl.ExtCtrls, Vcl.Menus, Vcl.Styles.Utils.ComCtrls,
      Vcl.Styles.Utils.Menus,
      Vcl.Styles.Utils.SysStyleHook,
      Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
      Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips;

    type
      TFormHome = class(TForm)
        gbFTP_Data: TGroupBox;
        lblHost: TLabel;
        txtHost: TEdit;
        lblUsername: TLabel;
        txtUsername: TEdit;
        lblPassword: TLabel;
        txtPassword: TEdit;
        btnConnect: TButton;
        gbMyFiles: TGroupBox;
        lblDirectory1: TLabel;
        txtMe_Directory: TEdit;
        btnListMe: TButton;
        lvLocalFiles: TListView;
        gbFTP_Files: TGroupBox;
        lblDirectory2: TLabel;
        txt_FTP_Directory: TEdit;
        btnList_FTP: TButton;
        lv_FTP_Files: TListView;
        btnUpload: TButton;
        btnDownload: TButton;
        directorios: TListBox;
        archivos: TListBox;
        status: TStatusBar;
        local_iconos: TImageList;
        ftp_client: TIdFTP;
        ftp_iconos: TImageList;
        progreso: TProgressBar;
        imgLogo: TImage;
        menu_local: TPopupMenu;
        MakeDirectory1: TMenuItem;
        Rename1: TMenuItem;
        Delete1: TMenuItem;
        Refresh1: TMenuItem;
        menu_ftp: TPopupMenu;
        MakeDirectory2: TMenuItem;
        Rename2: TMenuItem;
        Delete2: TMenuItem;
        Refresh2: TMenuItem;
        ilIconos: TImageList;
        procedure btnConnectClick(Sender: TObject);
        procedure btnListMeClick(Sender: TObject);
        procedure btnList_FTPClick(Sender: TObject);
        procedure btnUploadClick(Sender: TObject);
        procedure ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
          AWorkCount: Int64);
        procedure ftp_clientWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
          AWorkCountMax: Int64);
        procedure ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
        procedure btnDownloadClick(Sender: TObject);
        procedure lvLocalFilesDblClick(Sender: TObject);
        procedure lv_FTP_FilesDblClick(Sender: TObject);
        procedure MakeDirectory1Click(Sender: TObject);
        procedure Rename1Click(Sender: TObject);
        procedure Delete1Click(Sender: TObject);
        procedure Refresh1Click(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure MakeDirectory2Click(Sender: TObject);
        procedure Rename2Click(Sender: TObject);
        procedure Delete2Click(Sender: TObject);
        procedure Refresh2Click(Sender: TObject);

      private
        { Private declarations }
      public
        { Public declarations }
      end;

    var
      FormHome: TFormHome;

    implementation

    {$R *.dfm}

    procedure listar(dirnownow: string; ListaDeArchivos: TListView;
      ListaDeIconos: TImageList);
    var
      buscar: TSearchRec;
      Icon: TIcon;
      listate: TListItem;
      getdata: SHFILEINFO;
      dirnow: string;

    begin

      if (DirectoryExists(dirnownow)) then
      begin
        ListaDeIconos.Clear;

        dirnow := StringReplace(dirnownow, '/', '\', [rfReplaceAll, rfIgnoreCase]);

        ListaDeArchivos.Items.Clear;
        Icon := TIcon.Create;
        ListaDeArchivos.Items.BeginUpdate;

        if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
        begin
          repeat
            if (buscar.Attr = faDirectory) then
            begin

              with ListaDeArchivos do
              begin

                if not(buscar.Name = '.') and not(buscar.Name = '..') then
                begin

                  listate := ListaDeArchivos.Items.Add;

                  SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                    SizeOf(getdata), SHGFI_DISPLAYNAME);
                  listate.Caption := getdata.szDisplayName;

                  SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                    SizeOf(getdata), SHGFI_TYPENAME);
                  listate.SubItems.Add(getdata.szTypeName);

                  SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                    SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
                  Icon.Handle := getdata.hIcon;
                  listate.ImageIndex := ListaDeIconos.AddIcon(Icon);

                  DestroyIcon(getdata.hIcon);

                end;
              end;

            end;
          until FindNext(buscar) <> 0;
          FindClose(buscar);
        end;

        if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
        begin
          repeat
            if (buscar.Attr <> faDirectory) then
            begin

              with ListaDeArchivos do
              begin

                listate := ListaDeArchivos.Items.Add;

                SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                  SizeOf(getdata), SHGFI_DISPLAYNAME);
                listate.Caption := buscar.Name;

                SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                  SizeOf(getdata), SHGFI_TYPENAME);
                listate.SubItems.Add(getdata.szTypeName);

                SHGetFileInfo(PChar(dirnow + buscar.Name), 0, getdata,
                  SizeOf(getdata), SHGFI_ICON or SHGFI_SMALLICON);
                Icon.Handle := getdata.hIcon;
                listate.ImageIndex := ListaDeIconos.AddIcon(Icon);

                DestroyIcon(getdata.hIcon);

              end;

            end

            until FindNext(buscar) <> 0;
            FindClose(buscar);
          end;

          ListaDeArchivos.Items.EndUpdate;
        end;

      end;

      procedure listarftp(dirnownow2: string; ListaDeArchivosFTP: TListView;
        ftp: TIdFTP; DirectoriosEncontrados: TListBox;
        ArchivosEncontrados: TListBox);
      var
        i: integer;
        Item: TIdFTPListItem;
        listate2: TListItem;

      begin

        ListaDeArchivosFTP.Items.Clear;
        DirectoriosEncontrados.Clear;
        ArchivosEncontrados.Clear;

        listate2 := ListaDeArchivosFTP.Items.Add;

        ftp.ChangeDir(dirnownow2);
        ftp.List('*.*', True);

        for i := 0 to ftp.DirectoryListing.Count - 1 do
        begin

          Item := ftp.DirectoryListing.Items[i];
          if Item.ItemType = ditFile then
          begin
            DirectoriosEncontrados.Items.Add(ftp.DirectoryListing.Items[i]
              .FileName);
          end
          else
          begin
            ArchivosEncontrados.Items.Add(ftp.DirectoryListing.Items[i].FileName);
          end;

        end;

        ListaDeArchivosFTP.Items.Clear;

        for i := 0 to ArchivosEncontrados.Count - 1 do
        begin

          with ListaDeArchivosFTP do

          begin

            listate2 := ListaDeArchivosFTP.Items.Add;
            listate2.Caption := ArchivosEncontrados.Items[i];
            listate2.SubItems.Add('Directory');
            listate2.ImageIndex := 0;

          end;
        end;

        for i := 0 to DirectoriosEncontrados.Count - 1 do
        begin

          with ListaDeArchivosFTP do

          begin

            listate2 := ListaDeArchivosFTP.Items.Add;
            listate2.Caption := DirectoriosEncontrados.Items[i];
            listate2.SubItems.Add('File');
            listate2.ImageIndex := 1;

          end;
        end;

      end;

      procedure TFormHome.btnConnectClick(Sender: TObject);
      begin

        lv_FTP_Files.Items.Clear;

        directorios.Clear;
        archivos.Clear;

        if (btnConnect.Caption = 'Disconnect') then
        begin
          ftp_client.Disconnect;
          btnConnect.Caption := 'Connect';
          status.Panels[0].Text := '[+] Disconnected';
          FormHome.status.Update;
          txt_FTP_Directory.Text := '';
          MessageBox(0, 'Disconnected', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end
        else
        begin

          ftp_client.host := txtHost.Text;
          ftp_client.username := txtUsername.Text;
          ftp_client.password := txtPassword.Text;

          try
            ftp_client.connect;
            btnConnect.Caption := 'Disconnect';
            status.Panels[0].Text := '[+] Connected';
            FormHome.status.Update;

            txt_FTP_Directory.Text := '/';
            listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
              archivos);

            MessageBox(0, 'Connected', 'FTP Manager 1.0', MB_ICONINFORMATION);
          except
            status.Panels[0].Text := '[-] Error connecting to server';
            FormHome.status.Update;
            MessageBox(0, 'Error connecting to server', 'FTP Manager 1.0',
              MB_ICONERROR);
          end;
        end;

      end;

      procedure TFormHome.Delete1Click(Sender: TObject);
      var
        archivo: string;
      begin
        if Assigned(lvLocalFiles.Selected) then
        begin
          archivo := lvLocalFiles.Selected.Caption;
          if DeleteFile(txtMe_Directory.Text + '/' + archivo) then
          begin
            if not(txtMe_Directory.Text = '') then
            begin
              listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
            end;
            MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
          end
          else
          begin
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end;
      end;

      procedure TFormHome.Delete2Click(Sender: TObject);
      var
        archivo: string;
      begin
        if Assigned(lv_FTP_Files.Selected) then
        begin
          archivo := lv_FTP_Files.Selected.Caption;
          ftp_client.ChangeDir(txt_FTP_Directory.Text);
          try
            begin
              ftp_client.Delete(archivo);
              if not(txt_FTP_Directory.Text = '') then
              begin
                listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
                  directorios, archivos);
              end;
              MessageBox(0, 'Deleted', 'FTP Manager 1.0', MB_ICONINFORMATION);
            end;
          except
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end;
      end;

      procedure TFormHome.btnDownloadClick(Sender: TObject);
      var
        fileabajar: string;
      begin

        if Assigned(lv_FTP_Files.Selected) then
        begin
          try
            begin
              fileabajar := lv_FTP_Files.Selected.Caption;;
              ftp_client.OnWork := ftp_clientWork;
              ftp_client.ChangeDir(txt_FTP_Directory.Text);

              progreso.Max := ftp_client.Size(ExtractFileName(fileabajar)) div 1024;

              ftp_client.Get(fileabajar, txtMe_Directory.Text + '/' + fileabajar,
                False, False);

              if not(txtMe_Directory.Text = '') then
              begin
                listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
              end;

              MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
                MB_ICONINFORMATION);
            end;
          except
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end
        else
        begin
          MessageBox(0, 'Select File to download', 'FTP Manager 1.0',
            MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.FormCreate(Sender: TObject);
      begin
        UseLatestCommonDialogs := False;
        txtMe_Directory.Text := GetCurrentDir + '\';
        listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
      end;

      procedure TFormHome.ftp_clientWork(ASender: TObject; AWorkMode: TWorkMode;
        AWorkCount: Int64);
      begin
        status.Panels[0].Text := '[+] Working ...';
        FormHome.status.Update;

        progreso.Position := AWorkCount div 1024;
      end;

      procedure TFormHome.ftp_clientWorkBegin(ASender: TObject;
        AWorkMode: TWorkMode; AWorkCountMax: Int64);
      begin
        status.Panels[0].Text := '[+] Working ..';
        FormHome.status.Update;
      end;

      procedure TFormHome.ftp_clientWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
      begin
        status.Panels[0].Text := '[+] Finished';
        FormHome.status.Update;
        progreso.Max := 0;
      end;

      procedure TFormHome.lv_FTP_FilesDblClick(Sender: TObject);
      begin
        if Assigned(lv_FTP_Files.Selected) then
        begin
          if (lv_FTP_Files.Selected.SubItems.Strings[0] = 'Directory') then
          begin
            ftp_client.ChangeDir(txt_FTP_Directory.Text +
              lv_FTP_Files.Selected.Caption + '/');
            listarftp(txt_FTP_Directory.Text + lv_FTP_Files.Selected.Caption + '/',
              lv_FTP_Files, ftp_client, directorios, archivos);
            txt_FTP_Directory.Text := ftp_client.RetrieveCurrentDir + '/';
          end;
        end
        else
        begin
          MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.btnList_FTPClick(Sender: TObject);
      begin
        if not(txt_FTP_Directory.Text = '') then
        begin
          listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
            archivos);
        end
        else
        begin
          MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.btnListMeClick(Sender: TObject);
      begin
        if not(txtMe_Directory.Text = '') then
        begin
          listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
        end
        else
        begin
          MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.lvLocalFilesDblClick(Sender: TObject);
      begin
        if Assigned(lvLocalFiles.Selected) then
        begin
          if (DirectoryExists(txtMe_Directory.Text + lvLocalFiles.Selected.Caption +
            '/')) then
          begin
            Chdir(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/');
            listar(txtMe_Directory.Text + lvLocalFiles.Selected.Caption + '/',
              lvLocalFiles, local_iconos);
            txtMe_Directory.Text := GetCurrentDir + '\';
          end;
        end
        else
        begin
          MessageBox(0, 'Select Path', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.MakeDirectory1Click(Sender: TObject);
      var
        directorio: string;
      begin
        directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
        try
          begin
            MkDir(txtMe_Directory.Text + '/' + directorio);
            if not(txtMe_Directory.Text = '') then
            begin
              listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
            end;
            MessageBox(0, 'Directory created', 'FTP Manager 1.0',
              MB_ICONINFORMATION);
          end;
        except
          MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
        end;
      end;

      procedure TFormHome.MakeDirectory2Click(Sender: TObject);
      var
        directorio: string;
      begin
        directorio := InputBox('FTP Manager 1.0', 'Directory : ', '');
        try
          begin
            ftp_client.ChangeDir(txt_FTP_Directory.Text);
            ftp_client.MakeDir(directorio);
            if not(txt_FTP_Directory.Text = '') then
            begin
              listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
                directorios, archivos);
            end;
            MessageBox(0, 'Directory created', 'FTP Manager 1.0',
              MB_ICONINFORMATION);
          end;
        except
          MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
        end;
      end;

      procedure TFormHome.Refresh1Click(Sender: TObject);
      begin
        if not(txtMe_Directory.Text = '') then
        begin
          listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
        end
        else
        begin
          MessageBox(0, 'Write path', 'FTP Manager 1.0', MB_ICONINFORMATION);
        end;
      end;

      procedure TFormHome.Refresh2Click(Sender: TObject);
      begin
        if not(txt_FTP_Directory.Text = '') then
        begin
          listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client, directorios,
            archivos);
        end;
      end;

      procedure TFormHome.Rename1Click(Sender: TObject);
      var
        original, new_name: string;
      begin
        if Assigned(lvLocalFiles.Selected) then
        begin
          original := lvLocalFiles.Selected.Caption;
          new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
          if RenameFile(txtMe_Directory.Text + '/' + original,
            txtMe_Directory.Text + '/' + new_name) then
          begin
            if not(txtMe_Directory.Text = '') then
            begin
              listar(txtMe_Directory.Text, lvLocalFiles, local_iconos);
            end;
            MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
          end
          else
          begin
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end;
      end;

      procedure TFormHome.Rename2Click(Sender: TObject);
      var
        original, new_name: string;
      begin
        if Assigned(lv_FTP_Files.Selected) then
        begin
          original := lv_FTP_Files.Selected.Caption;
          new_name := InputBox('FTP Manager 1.0', 'New name : ', '');
          try
            begin
              ftp_client.ChangeDir(txt_FTP_Directory.Text);
              ftp_client.Rename(original, new_name);
              if not(txt_FTP_Directory.Text = '') then
              begin
                listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
                  directorios, archivos);
              end;
              MessageBox(0, 'Changed', 'FTP Manager 1.0', MB_ICONINFORMATION);
            end;
          except
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end;

      end;

      procedure TFormHome.btnUploadClick(Sender: TObject);
      var
        fileasubir: string;
        dirasubir: string;
        cantidad: File of byte;
      begin

        if Assigned(lvLocalFiles.Selected) then
        begin
          try
            begin
              fileasubir := txtMe_Directory.Text + lvLocalFiles.Selected.Caption;
              dirasubir := txt_FTP_Directory.Text;

              ftp_client.OnWork := ftp_clientWork;

              AssignFile(cantidad, fileasubir);
              Reset(cantidad);
              progreso.Max := FileSize(cantidad) div 1024;
              CloseFile(cantidad);

              ftp_client.ChangeDir(dirasubir);
              ftp_client.Put(fileasubir, lvLocalFiles.Selected.Caption, False);

              if not(txt_FTP_Directory.Text = '') then
              begin
                listarftp(txt_FTP_Directory.Text, lv_FTP_Files, ftp_client,
                  directorios, archivos);
              end;

              MessageBox(0, 'Action completed successfully', 'FTP Manager 1.0',
                MB_ICONINFORMATION);
            end;
          except
            MessageBox(0, 'Error', 'FTP Manager 1.0', MB_ICONERROR);
          end;
        end
        else
        begin
          MessageBox(0, 'Select File to upload', 'FTP Manager 1.0',
            MB_ICONINFORMATION);
        end;
      end;

    end.

    // The End ?


    Si quieren bajar el programa lo pueden hacer de aca.

+ 1 Oculto(s)

ohh delphi jamas lo use, pero es un lenguaje muy destacable y con historia, por ejemplo total comander fue desarrollado en delphi...

saludos...