[Delphi] FTP Manager 1.0

BigBear · Agosto 05, 2016, 11:01:10 PM

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


// 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 No tienes permitido ver los links. Registrarse o Entrar a mi cuenta.

[Delphi] FTP Manager 1.0

BigBear

Agosto 05, 2016, 11:01:10 PM