[Delphi] Project File X 0.2

BigBear · Junio 29, 2013, 01:56:10 PM

Un simple cliente FTP que eh estado haciendo en Delphi con las siguientes opciones :

Listar archivos del servidor FTP
Permite moverse por los directorios
Se pueden subir y bajar archivos
Se pueden crear y borrar carpetas

Se pueden renombrar y borrar archivos

Tambien tienen una tabla que les permite navegar por los directorios de sus computadoras para que les sea mas comodo bajar y subir archivos.

Una imagen :

El codigo

Código: delphi


// Project File X 0.2
// Coded By Doddy H
// Credits :
// Files Manager based on : http://www.swissdelphicenter.ch/torry/showcode.php?id=421
// Upload file based on : http://delphiallimite.blogspot.com.ar/2007/06/subiendo-archivos-por-ftp-con-indy.html
// Download file based : http://delphiallimite.blogspot.com.ar/2007/06/descargango-archivos-por-ftp-con-indy.html

unit ftp;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ImgList, sSkinManager, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdExplicitTLSClientServerBase, IdFTP, ComCtrls, sListView,
  StdCtrls, sButton, sEdit, sLabel, sGroupBox, acProgressBar, sStatusBar,
  IdFTPList,
  ShellAPI, sListBox, jpeg, ExtCtrls, Menus;

type
  TForm1 = class(TForm)
    IdFTP1: TIdFTP;
    sSkinManager1: TsSkinManager;
    ImageList1: TImageList;
    sGroupBox1: TsGroupBox;
    sLabel1: TsLabel;
    sEdit1: TsEdit;
    sButton1: TsButton;
    sListView1: TsListView;
    sGroupBox2: TsGroupBox;
    sLabel2: TsLabel;
    sEdit2: TsEdit;
    sLabel3: TsLabel;
    sEdit3: TsEdit;
    sLabel4: TsLabel;
    sEdit4: TsEdit;
    sButton2: TsButton;
    sStatusBar1: TsStatusBar;
    sProgressBar1: TsProgressBar;
    sGroupBox3: TsGroupBox;
    sLabel5: TsLabel;
    sEdit5: TsEdit;
    sButton3: TsButton;
    sListView2: TsListView;
    ListBox1: TListBox;
    ListBox2: TListBox;
    ImageList2: TImageList;
    sButton5: TsButton;
    Image1: TImage;
    sButton4: TsButton;

    PopupMenu1: TPopupMenu;
    D1: TMenuItem;
    R1: TMenuItem;
    R2: TMenuItem;
    M1: TMenuItem;
    D2: TMenuItem;

    PopupMenu2: TPopupMenu;
    C1: TMenuItem;
    D3: TMenuItem;
    D4: TMenuItem;
    R3: TMenuItem;
    R4: TMenuItem;
    PopupMenu3: TPopupMenu;
    A1: TMenuItem;
    E1: TMenuItem;
    procedure sButton3Click(Sender: TObject);
    procedure sListView1DblClick(Sender: TObject);
    procedure sButton1Click(Sender: TObject);
    procedure sButton2Click(Sender: TObject);
    procedure IdFTP1Connected(Sender: TObject);
    procedure sListView2DblClick(Sender: TObject);
    procedure sButton5Click(Sender: TObject);
    procedure IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
    procedure IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
    procedure IdFTP1WorkEnd(ASender: TObject; AWorkMode: TWorkMode);
    procedure FormCreate(Sender: TObject);
    procedure sButton4Click(Sender: TObject);
    procedure R1Click(Sender: TObject);
    procedure R2Click(Sender: TObject);

    procedure D2Click(Sender: TObject);
    procedure D1Click(Sender: TObject);
    procedure M1Click(Sender: TObject);
    procedure C1Click(Sender: TObject);
    procedure D3Click(Sender: TObject);
    procedure D4Click(Sender: TObject);
    procedure R3Click(Sender: TObject);
    procedure R4Click(Sender: TObject);
    procedure D5Click(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure E1Click(Sender: TObject);
    procedure IdFTP1Disconnected(Sender: TObject);

  private

    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure listarftp(dirnownow2: string; sListView2: TsListView; IdFTP1: TIdFTP;
  sListbox1: TListBox; sListbox2: TListBox; ImageList1: TImageList);
var
  i: integer;
  Item: TIdFTPListItem;
  listate2: TListItem;

begin

  sListView2.Items.Clear;
  sListbox1.Clear;
  sListbox2.Clear;

  listate2 := sListView2.Items.Add;

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

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

    Item := IdFTP1.DirectoryListing.Items[i];
    if Item.ItemType = ditFile then
    begin
      sListbox1.Items.Add(IdFTP1.DirectoryListing.Items[i].FileName);
    end
    else
    begin
      sListbox2.Items.Add(IdFTP1.DirectoryListing.Items[i].FileName);
    end;

  end;

  sListView2.Items.Clear;

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

    with sListView2 do

    begin

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

    end;
  end;

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

    with sListView2 do

    begin

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

    end;
  end;

end;

procedure listar(dirnownow: string; sListView1: TsListView;
  ImageList1: TImageList);
var
  buscar: TSearchRec;
  Icon: TIcon;
  listate: TListItem;
  getdata: SHFILEINFO;
  dirnow: string;

begin

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

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

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

        with sListView1 do
        begin

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

            listate := sListView1.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 := ImageList1.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 sListView1 do
        begin

          listate := sListView1.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 := ImageList1.AddIcon(Icon);

          DestroyIcon(getdata.hIcon);

        end;

      end

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

    sListView1.Items.EndUpdate;

  end;

  procedure TForm1.FormCreate(Sender: TObject);
  begin
    sProgressBar1.Max := 0;

    sSkinManager1.SkinDirectory := ExtractFilePath(Application.ExeName)
      + 'Data';
    sSkinManager1.SkinName := 'matrix';
    sSkinManager1.Active := True;

  end;

  procedure TForm1.A1Click(Sender: TObject);
  begin
    ShowMessage('Contact to lepuke[at]hotmail[com]');
  end;

  procedure TForm1.C1Click(Sender: TObject);
  var
    newdir: string;
  begin

    newdir := InputBox('Write the name', 'Directory : ', 'test');

    try
      begin
        IdFTP1.ChangeDir(sEdit5.Text);
        IdFTP1.MakeDir(newdir);
        ShowMessage('Directory created');
      end
    except
      begin
        ShowMessage('Error');
      end;
    end;

  end;

  procedure TForm1.D1Click(Sender: TObject);
  begin

    try
      begin
        RmDir(sEdit1.Text + sListView1.Selected.Caption);
        ShowMessage('Directory Deleted');
      end;
    except
      begin
        ShowMessage('Error');
      end;

    end;

  end;

  procedure TForm1.D2Click(Sender: TObject);
  begin

    if DeleteFile(sEdit1.Text + sListView1.Selected.Caption) then
    begin
      ShowMessage('File Deleted');
    end
    else
    begin
      ShowMessage('Error');
    end;

  end;

  procedure TForm1.IdFTP1Connected(Sender: TObject);
  begin
    sStatusBar1.Panels[0].Text := '[+] OnLine';
    Form1.sStatusBar1.Update;
  end;

  procedure TForm1.IdFTP1Disconnected(Sender: TObject);
  begin
    sStatusBar1.Panels[0].Text := '[+] OffLine';
    Form1.sStatusBar1.Update;
  end;

  procedure TForm1.IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
    AWorkCount: Int64);
  begin

    sStatusBar1.Panels[0].Text := '[+] Working ...';
    Form1.sStatusBar1.Update;

    sProgressBar1.Position := AWorkCount div 1024;
  end;

  procedure TForm1.IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
    AWorkCountMax: Int64);
  begin

    sStatusBar1.Panels[0].Text := '[+] Working ..';
    Form1.sStatusBar1.Update;

  end;

  procedure TForm1.IdFTP1WorkEnd(ASender: TObject; AWorkMode: TWorkMode);
  begin
    sStatusBar1.Panels[0].Text := '[+] Finished';
    Form1.sStatusBar1.Update;
    sProgressBar1.Max := 0;
  end;

  procedure TForm1.M1Click(Sender: TObject);
  var
    nombrecarpeta: string;
  begin

    chdir(sEdit1.Text);
    nombrecarpeta := InputBox('Write the name', 'Directory : ', 'test');
    try
      begin
        MkDir(nombrecarpeta);
        ShowMessage('Folder Created');
      end;
    except
      begin
        ShowMessage('Error');
      end;

    end;

  end;

  procedure TForm1.R1Click(Sender: TObject);
  var
    nuevonombre: string;
  begin
    nuevonombre := InputBox('Write the name', 'New name : ', 'testar');

    chdir(sEdit1.Text);
    if RenameFile(sListView1.Selected.Caption, nuevonombre) then
    begin
      ShowMessage('Ok');
    end
    else
    begin
      ShowMessage('Error');
    end;
  end;

  procedure TForm1.R2Click(Sender: TObject);
  begin
    listar(sEdit1.Text, sListView1, ImageList1);
  end;

  procedure TForm1.R3Click(Sender: TObject);
  var
    newname: string;
  begin

    newname := InputBox('Write the name', 'New name : ', 'testar');

    try
      begin
        IdFTP1.ChangeDir(sEdit5.Text);
        IdFTP1.Rename(sListView2.Selected.Caption, newname);
        ShowMessage('File rename');
      end;
    except
      begin
        ShowMessage('Error');
      end;
    end;
  end;

  procedure TForm1.R4Click(Sender: TObject);
  begin
    listarftp(sEdit5.Text, sListView2, IdFTP1, ListBox1, ListBox2, ImageList2);
  end;

  procedure TForm1.sButton1Click(Sender: TObject);
  begin
    listar(sEdit1.Text, sListView1, ImageList1);
  end;

  procedure TForm1.sButton2Click(Sender: TObject);
  begin

    sListView1.Items.Clear;
    sListView2.Items.Clear;

    ListBox1.Clear;
    ListBox2.Clear;

    if (sButton2.Caption = 'Disconnect') then
    begin
      IdFTP1.Disconnect;
      sButton2.Caption := 'Connect';
    end
    else
    begin

      IdFTP1.Host := sEdit2.Text;
      IdFTP1.Username := sEdit3.Text;
      IdFTP1.Password := sEdit4.Text;

      try
        IdFTP1.Connect;
        sButton2.Caption := 'Disconnect';
      except
        sStatusBar1.Panels[0].Text := '[-] Error';
        Form1.sStatusBar1.Update;
      end;
    end;
  end;

  procedure TForm1.sButton3Click(Sender: TObject);
  begin
    listarftp(sEdit5.Text, sListView2, IdFTP1, ListBox1, ListBox2, ImageList2);
  end;

  procedure TForm1.sButton4Click(Sender: TObject);
  var
    fileabajar: string;
  begin

    fileabajar := sListView2.Selected.Caption; ;
    IdFTP1.OnWork := IdFTP1Work;
    IdFTP1.ChangeDir(sEdit5.Text);

    sProgressBar1.Max := IdFTP1.Size(ExtractFileName(fileabajar)) div 1024;

    IdFTP1.Get(fileabajar, sEdit1.Text + '/' + fileabajar, False, False);

  end;

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

    fileasubir := sEdit1.Text + sListView1.Selected.Caption;
    dirasubir := sEdit5.Text;

    IdFTP1.OnWork := IdFTP1Work;

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

    IdFTP1.ChangeDir(dirasubir);
    IdFTP1.Put(fileasubir, sListView1.Selected.Caption, False);

  end;

  procedure TForm1.sListView1DblClick(Sender: TObject);
  var
    dir: string;
  begin

    dir := sEdit1.Text + sListView1.Selected.Caption + '/';
    if (DirectoryExists(dir)) then
    begin
      sEdit1.Text := sEdit1.Text + sListView1.Selected.Caption + '/';
      listar(dir, sListView1, ImageList1);
    end;
  end;

  procedure TForm1.sListView2DblClick(Sender: TObject);
  var
    dir: string;
  begin
    dir := sEdit5.Text + sListView2.Selected.Caption + '/';
    sEdit5.Text := sEdit5.Text + sListView2.Selected.Caption + '/';
    listarftp(dir, sListView2, IdFTP1, ListBox1, ListBox2, ImageList2);
  end;

  procedure TForm1.D3Click(Sender: TObject);
  begin
    try
      begin
        IdFTP1.ChangeDir(sEdit5.Text);
        IdFTP1.Delete(sListView2.Selected.Caption);
        ShowMessage('File Deleted');
      end;
    except
      begin
        ShowMessage('Error');
      end;
    end;
  end;

  procedure TForm1.D4Click(Sender: TObject);
  begin

    try
      begin
        IdFTP1.ChangeDir(sEdit5.Text);
        IdFTP1.RemoveDir(sListView2.Selected.Caption);
        ShowMessage('Directory Deleted');
      end
    except
      ShowMessage('Error');
    end;

  end;

  procedure TForm1.D5Click(Sender: TObject);
  begin
    IdFTP1.Disconnect;
  end;

  procedure TForm1.E1Click(Sender: TObject);
  begin
    Form1.Close();
  end;

end.

// The End ?

Si lo quieren bajar lo pueden hacer de No tienes permitido ver los links. Registrarse o Entrar a mi cuenta

ZanGetsu · Junio 29, 2013, 02:12:03 PM

se ve muy bueno, lo probaré, gracias !

[Delphi] Project File X 0.2

BigBear

Junio 29, 2013, 01:56:10 PM

ZanGetsu

Junio 29, 2013, 02:12:03 PM #1