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.