Delphi [Delphi] FTP Manager 1.0

Doddy · Aug 6, 2016

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 :

Code:

&gt;
// 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) &lt;&gt; 0;
     FindClose(buscar);
   end;

   if FindFirst(dirnow + '*.*', faAnyFile, buscar) = 0 then
   begin
     repeat
       if (buscar.Attr &lt;&gt; 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) &lt;&gt; 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 [HIDE-THANKS]

This link is hidden for visitors. Please Log in or register now.

[/HIDE-THANKS]

IP Tools

Basic Encoders/Decoders

Hash Generators

Classical Ciphers

Modern Cryptography

Other Tools

Delphi [Delphi] FTP Manager 1.0

Doddy

Leech