• explorador de archivos (local)estilo rat

 #486304  por joselin
 17 May 2016, 01:10
hola queria compartirles este codigo
hay que mejorar el acceso a unidades no preparadas(cd romm vacios),
podria ser alguna comprobacion
hay un retardo importante al listar la carpeta system32(4,5 segundos)
lo vi en todos los rat en delphi, habria que ponerle algun thread
no estoy muy familiarizado con los threads
mejorar el agregado de icono de carpeta lo tomo de un timage cargado con la imagen de una carpeta

unit Unit1;
{ JOSELIN 2016 34 AÑOS....:)


http://delphi.about.com/od/delphitips2008/qt/filesize.htm
function FormatFileSize  Credit P0ke
 filemanager basado en principio en smart rat  thow4ever.blogspot.com
 asociasion de iconos http://stackoverflow.com/questions/829843/how-to-get-icon-and-description-from-file-extension-using-delphi

 el resto de la gigantesca  internet
                                   }

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Menus, ImgList,shellapi, ExtCtrls;

type
  TForm1 = class(TForm)
    ListView1: TListView;
    ComboBoxEx1: TComboBoxEx;
    Button1: TButton;
    Edit1: TEdit;
    PopupMenu1: TPopupMenu;
    ImageList1: TImageList;
    actualizar1: TMenuItem;
    Label1: TLabel;
    Button2: TButton;
    ImageList2: TImageList;
    ComboBox1: TComboBox;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
    procedure listando(pathfolder,pathfiles:string);
   
     function GetFileInfo(AExt : tstringlist ) :tstringlist;
   
    procedure AddBitmap(ImageList: TImageList; Bmp: TBitmap);
    procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure ComboBox1Change(Sender: TObject);
    procedure actualizar1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

  function tform1.GetFileInfo(AExt : tstringlist ) :tstringlist;
boolean = false) : boolean;
var
 AInfo : tSHFileInfo ;
uFlags : integer;
icon:ticon;
i:integer;
extension:string;
INFOTIPO:tSTRINGLIST;
ImageList : TImagelist;
begin
infotipo:=tstringlist.create;
      Icon := TIcon.Create;
      infotipo.Clear;
      ImageList := TImageList.Create(Self);
  try
    // Loop through all stored extensions and retrieve relevant info

 for i := 0 to aext.Count - 1 do
    begin
    Extension := '*' +ExtractFileExt(aext.Strings[i]);

zeromemory (@AInfo,SizeOf(TSHFileInfo));
uFlags := SHGFI_ICON +SHGFI_SMALLICON + SHGFI_TYPENAME + SHGFI_USEFILEATTRIBUTES;

//uFlags := SHGFI_TYPENAME+SHGFI_USEFILEATTRIBUTES;
//if ALargeIcon then
//uFlags := uFlags + SHGFI_LARGEICON
//else
//uFlags := uFlags + SHGFI_SMALLICON;
SHGetFileInfo(PChar(extension),FILE_ATTRIBUTE_NORMAL,AInfo,SizeOf(ainfo),uFlags);

icon.Handle := AInfo.hIcon;


imagelist1.addicon(icon);

   infotipo.Add(aInfo.szTypeName);
    end;
  finally
    Icon.Free;
  end;
result:=infotipo;


end;




// returns file size in bytes or -1 if not found.
function FileSize(fileName : wideString) : Int64;
 var
 sr : TSearchRec;
 begin
  if FindFirst(fileName, faAnyFile, sr ) = 0 then
     result := Int64(sr.FindData.nFileSizeHigh) shl Int64(32) + Int64(sr.FindData.nFileSizeLow)
      else
        result := -1;
        FindClose(sr) ;
         end;



function FormatFileSize(Size: extended): string;
{Credit P0ke}
begin
  if Size = 0 then
  begin
    Result := '0 B';
  end
  else if Size < 1000 then
  begin
    Result := FormatFloat('0', Size) + ' B';
  end
  else
  begin
    Size := Size / 1024;
    if (Size < 1000) then
    begin
      Result := FormatFloat('0.0', Size) + ' KB';
    end
    else
    begin
      Size := Size / 1024;
      if (Size < 1000) then
      begin
        Result := FormatFloat('0.00', Size) + ' MB';
      end
      else
      begin
        Size := Size / 1024;
        if (Size < 1000) then
        begin
          Result := FormatFloat('0.00', Size) + ' GB';
        end
        else
        begin
          Size := Size / 1024;
          if (Size < 1024) then
          begin
            Result := FormatFloat('0.00', Size) + ' TB';
          end
        end
      end
    end
  end;
end;

 procedure tform1.AddBitmap(ImageList: TImageList; Bmp: TBitmap);
var

mask : TBitmap;
begin
  mask := TBitmap.Create;
  try
   mask.Assign(Bmp);
   ImageList.Add(Bmp, mask);
     //almacena en index := 0
   finally
    mask.Free;
  end;
end;





//listar drivers

   function AddDrives:string;
var
  cDrives       :Array[0..128] of char;
  pDrive        :PChar;
  Icon          :TIcon;
  shInfo        :TSHFileInfo;

  str:tstringlist;
begin
str:=tstringlist.Create;
result:='';
  if GetLogicalDriveStrings(SizeOf(cDrives),cDrives) = 0 then exit;

  pDrive := cDrives;
  Icon := TIcon.Create;
  while pDrive^ <> #0 do
  begin

    SHGetFileInfo(pChar(pdrive), 0, shInfo, SizeOf(shInfo),SHGFI_ICON or SHGFI_SMALLICON or SHGFI_SYSICONINDEX);
    Icon.Handle := shInfo.hIcon;
    form1.imagelist2.AddIcon(Icon);

    str.text:=str.text+pdrive;

    Inc(pDrive,4);

  end;
  Icon.Free;
  result:=str.text;

end;


//listar carpetas
 function Listfolder(Directory: String): string;
var
FileName,Filelist,Dirlist:string;
Searchrec:TWin32FindData;
Dircount,Filecount:integer;
FindHandle:THandle;
ReturnStr:string;
begin

 filecount:=0;
 dircount:=0;
 ReturnStr:='';

 try
   FindHandle:=FindFirstFile(pchar(Directory +'*.*'),searchrec);
   if FindHandle <> INVALID_HANDLE_VALUE then
   repeat
   FileName:=searchrec.cFileName;
   if((searchrec.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)<>0)then
   begin
   dirlist:=dirlist+(filename+#13);
  //  dircount:=dircount+1;
    end
    else
    begin
    filelist:=filelist+(filename+#13);
   // filecount:=filecount+1;
    end;
    until FindNextFile(FindHandle,searchrec)=false;
    finally
    Windows.FindClose(FindHandle);
    end;
    ReturnStr:=(dirlist);
    Result:=ReturnStr;
end;
//***listar archivos
procedure ListFileDir(Path: string; FileList: TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
  begin
    repeat
      if (SR.Attr and faDirectory)<> faDirectory then
      begin
        FileList.Add(SR.Name);
      end;
    until FindNext(SR) <> 0;
    FindClose(SR);
  end;
end;
//****fin listar archivos

procedure tform1.listando(pathfolder,pathfiles:string) ;
var
AInfo : TSHFileInfo;
 f:string;
l2:tlistitem;
i:integer;
listafolder:tstringlist;
listarchivos:tstringlist;
listartipos:tstringlist;
begin
// agrego la imagen de carpeta al imagelist1
  AddBitmap(ImageList1,image1.Picture.Bitmap);


    listafolder := TStringList.Create;
    listarchivos:=  tstringlist.create;
    listartipos:=tstringlist.Create;

listafolder.Clear;
listarchivos.clear;





//listar carpetas



       listafolder.Text:= Listfolder(pathfolder);
      // eliminar el punto como directorio
      if listafolder.Strings[0] = '.' then
      listafolder.Delete(0);
                    //----------------
                    //listar archivos
      listfiledir(pathfiles,listarchivos);


        listartipos:=GetFileInfo( listarchivos);
                //--------------------


      for i:=0 to listafolder.Count-1 do begin
      L2 := listview1.Items.Add;
      L2.Caption := listafolder.Strings[i];
      l2.SubItems.Add('carpeta');
      l2.imageindex:=0;
       end;
        listafolder.Free;


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


           L2 := listview1.Items.Add;
          L2.Caption := listarchivos.Strings[i];

          l2.SubItems.Add(listartipos.strings[i]);
          L2.SubItems.Add(FormatFileSize(FileSize(edit1.Text+listarchivos[i])));
           l2.imageindex:=i+2;
           end;
           listarchivos.Free;
           listartipos.Free;

           end;

procedure TForm1.Button1Click(Sender: TObject);
var
e,i:integer;
listardrives:tstringlist;
ast:string;
begin

  ///parte del combobox
    combobox1.Clear;
     listardrives:=tstringlist.create;
     listardrives.text:=AddDrives;

      for e:=0 to listardrives.Count-1 do begin
      combobox1.Items.Add(listardrives[e]) ;
      end;
          listardrives.free;


  end;
procedure TForm1.ListView1DblClick(Sender: TObject);

begin
     //si la imagen es de una carpeta entonces
if listview1.Selected.ImageIndex = 0 then begin
       //si es un subdirectorio
 if listview1.Selected.Caption = '..' then
     edit1.Text:=ExtractFilePath(Copy(edit1.Text,1,Length(edit1.Text)-1))
  else
     //si es el directorio principal c:\
      edit1.Text := edit1.Text+listview1.Selected.Caption+'\';

     //cada vez que se accede se ponen los valore a cero
    Listview1.Clear;   //borrar los datos
    imagelist1.Clear;//borrar los iconos

   listando(edit1.text,edit1.text);
 end
   else
   begin

   showmessage('showmessage no es una carpeta');
end; 
 end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
    AnIcon : TIcon;
begin
    AnIcon := TIcon.Create;
    try
        form1.ImageList2.GetIcon (Index,AnIcon);
        with Control as TComboBox do begin
            Canvas.Draw (Rect.Left,Rect.Top,AnIcon);
            Canvas.TextOut (Rect.Left + form1.ImageList2.Width,Rect.Top,Items[Index]);
        end;
    finally
        AnIcon.Free;
    end;

end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin

   edit1.Text:= ComboBox1.Text;
     //cada vez que se accede se ponen los valore a cero
   Listview1.Clear;
   imagelist1.Clear; //borramos los index de iconos viej0s

     if combobox1.Text= 'A:\' THEN
     SHOWMESSAGE ('UNIDAD BLOQUEADA PARA EVITAR ERROR'+#10#13+'quien mierda usa una disketera en el 2016?' )
     ELSE
    listando(combobox1.text,edit1.text) ;

end;

procedure TForm1.actualizar1Click(Sender: TObject);
begin
    Listview1.Clear;
    imagelist1.Clear;
   listando(edit1.text,edit1.text);
end;

end.
 #486330  por Pink
 17 May 2016, 20:30
Excelente lo lograste. No lo mire muy bien por que ya la sintaxis de delphi me fastidia :S Una cosita olvidate del mix English/Spanish como ListArchivo usa ListFiles o algo parecido . Tambien podrias empezar a trabajar mas dinámica por ejemplo en ese código crear una clase aparte que seria la util/portable etc...

Saludos