Файловый менеджер с поддержкой поиска mp3-файлов по ID3-параметрам

begin

  Activate;

SetPath(CurrentFullPath+'..');

end;

procedure TfrFilePanel.btDirRootClick(Sender: TObject);

begin

  Activate;

SetPath(IncludeTrailingBackslash(ExtractFileDrive(CurrentFullPath)));

end;

procedure TfrFilePanel.lvFilesColumnRightClick(Sender: TObject;

  Column: TListColumn; Point: TPoint);

begin

  Activate;

  Column.Width:=-1;

end;

procedure TfrFilePanel.lvFilesEditing(Sender: TObject; Item: TListItem;

var AllowEdit: Boolean);

Var

  FileItem:TFileRecord;

  NewName:String;

begin

  AllowEdit:=False;

GetItemByList(Item, FileItem);

  If FileItem.Name=DirUpItem.Name Then Exit;

//  If IsDirectory(FileItem) Then Exit;

  NewName:=GetFullName(FileItem);

  If GetNameQuery('Переименовать "'+NewName+'" в:', NewName) Then

  Begin

    If TryRename(Item, NewName) Then Refresh;

  End;

  AllowEdit:=False;

end;

procedure TfrFilePanel.lvFilesInfoTip(Sender: TObject; Item: TListItem;

var InfoTip: String);

begin

{  If ((lvFiles.StringWidth(InfoTip)+40<lvFiles.Columns[0].Width) Or (lvFiles.Columns[0].Width<0)) Then

  Begin

    InfoTip:='';

    Exit;

  End;

  If Item.SubItems[0]<>'' Then

    InfoTip:=InfoTip+'.'+Item.SubItems[0];}

end;

procedure TfrFilePanel.lvFilesChange(Sender: TObject; Item: TListItem;

  Change: TItemChange);

{Var

  FileItem:TFileRecord;

  ID:Integer;}

Begin

  MakeOutLabels;

{  GetItemByList(Item, FileItem);

  ID:=FileItem.ID;

AllFiles.Items[ID].Checked:=Item.Checked;

  If Item.Checked Then

    pnFilesInfo.Caption:=Item.Caption+' Checked'

  Else

    pnFilesInfo.Caption:=Item.Caption+' NonChecked';}

end;

procedure TfrFilePanel.lvFilesEnter(Sender: TObject);

begin

  Activate;

end;

procedure TfrFilePanel.lvFilesExit(Sender: TObject);

begin

//  Deactivate;

end;

procedure TfrFilePanel.lbCurrentPathClick(Sender: TObject);

begin

  Activate;

end;

procedure TfrFilePanel.bbRefreshClick(Sender: TObject);

begin

  Refresh;

  Activate;

end;

function TfrFilePanel.NameDir:string;

var

  Item:TFileRecord;

  DirName:String;

begin

GetItemByList(lvFiles.ItemFocused, Item);

  DirName:=GetFullName(Item);

  NameDir:=DirName;

end;

procedure TfrFilePanel.CopyDir(const FromFolder: string; const ToFolder: string);

var

Fo      : TSHFileOpStruct;

buffer  : array[0..4096] of char;

p       : pchar;

begin

  //If Not(GetNameQuery('Скопироватьфайл "'+GetFullName(Item)+'" в:', FileName)) Then Exit;

FillChar(Buffer, sizeof(Buffer), #0);

p := @buffer;

StrECopy(p, PChar(FromFolder)); //директория, которую мы хотим скопировать

FillChar(Fo, sizeof(Fo), #0);

  Fo.Wnd    := Application.Handle;

Fo.wFunc  := FO_COPY;

Fo.pFrom  := @Buffer;

Fo.pTo    := PChar(ToFolder); //куда будет скопирована директория

Fo.fFlags := 0;

if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then

ShowMessage('File copy process cancelled')

end;

function TfrFilePanel.FullRemoveDir(Dir: string; DeleteAllFilesAndFolders,

   StopIfNotAllDeleted, RemoveRoot: boolean): Boolean;

var

i: Integer;

   SRec: TSearchRec;

   FN, TmpStr: string;

   ListItem:TListItem;

   Item:TFileRecord;

begin

  ListItem:=lvFiles.ItemFocused;

GetItemByList(ListItem, Item);

  If IsDirectory(Item) Then

begin

Result := False;

if not DirectoryExists(Dir) then

exit;

   Result := True;

   // Добавляем  слэш в конце и задаем маску  - "все файлы и директории"

Dir := IncludeTrailingBackslash(Dir);

i := FindFirst(Dir + '*', faAnyFile, SRec);

try

     while i = 0 do

     begin

       // Получаем полный путь к файлу  или директорию

       FN := Dir + SRec.Name;

       // Если это директория

if SRec.Attr = faDirectory then

begin

// Рекурсивный  вызов этой же функции с  ключом удаления корня

if (SRec.Name <> '') and (SRec.Name <> '.') and (SRec.Name <> '..') then

begin

if DeleteAllFilesAndFolders then

FileSetAttr(FN, faArchive);

Result := FullRemoveDir(FN, DeleteAllFilesAndFolders,

             StopIfNotAllDeleted, True);

if not Result and StopIfNotAllDeleted then

exit;

end;

end

else // Иначеудаляемфайл

begin

if DeleteAllFilesAndFolders then

FileSetAttr(FN, faArchive);

Result := SysUtils.DeleteFile(FN);

if not Result and StopIfNotAllDeleted then

exit;

       end;

       // Берем следующий файл или  директорию

i := FindNext(SRec);

end;

finally

SysUtils.FindClose(SRec);

end;

if not Result then

exit;

if RemoveRoot then // Если  необходимо удалить корень - удаляем

if not RemoveDir(Dir) then

Result := false;

end

else  deletefile(dir);

end;

end. 

Листинг2 – Модуль FilesExU.pas

{ Модуль FilesExU.pas } { гр. П-1 }

{ Разработчик: Герасимчук, А.В.} { Модифицирован: 10 июня 2011 }

{ )

{ Содержит функции построения списка файлов } 

unit FilesExU; 

interface

Uses

  SysUtils, FileCtrl, ShellApi, Windows; 

Const

  F_ER_SUCCESS=0;

  F_ER_HIMSELF=-1;

  F_ER_EXISTS =-2;

  F_ER_NOT_EXISTS=-3;

  F_ER_DIREXISTS=-4;

  F_ER_NOTCOPY=-128;

  F_ER_ERROR=-255; 

  ConstCopyToDir:String=''; 

Procedure GetDiskSize(CurrentDrive:Char; Var TotalBytes, TotalFree:Int64);

Procedure GetRealDiskSize(Drive:Char; Var TotalBytes, TotalFree:Double); 

Function ExecuteOneFile(WorkDir, FileName, Params:String):Integer;

Function GetExecuteError(ErrorCode:Integer):String; 

Function CopyOneFile(FromFile, ToFile:String; PrevCheck:Boolean):Integer;

Function GetFileError(ErrorCode:Integer):String; 

Function RenameOneFile(OldName, NewName:String):Integer;

Function DeleteOneFile(FileName:String):Integer;

Function DeleteOneDir(FileName:String):Integer; 

Function CreateOneFolder(FolderName:String):Integer; 

implementation 
 

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;

var lpFreeBytesAvailableToCaller : Integer;

var lpTotalNumberOfBytes: Integer;

var lpTotalNumberOfFreeBytes: Integer) : boolean;

stdcall;

external 'kernel32'

name 'GetDiskFreeSpaceExA'; 

Procedure GetDiskSize(CurrentDrive:Char; Var TotalBytes, TotalFree:Int64);

Var

  Drive:Byte;

Begin

  CurrentDrive:=UpCase(CurrentDrive);

  Drive:=Ord(CurrentDrive)-64;

  TotalBytes:=DiskSize(Drive);

  TotalFree:=DiskFree(Drive);

End;

 

Procedure GetRealDiskSize(Drive:Char; Var TotalBytes, TotalFree:Double);

Var

AvailToCall : integer;

TheSize : integer;

FreeAvail : integer;

  TheDrive:String;

Begin

  TheDrive:=Drive+':\'+#0; 

GetDiskFreeSpaceEx(@TheDrive[1], AvailToCall, TheSize, FreeAvail);

{$IFOPT Q+}

{$DEFINE TURNOVERFLOWON}

{$Q-}

{$ENDIF}

  If TheSize >= 0 then

TotalBytes := TheSize

  Else

if TheSize = -1 then

begin

TotalBytes := $7FFFFFFF;

TotalBytes := TotalBytes * 2;

TotalBytes := TotalBytes + 1;

end

else begin

TotalBytes := $7FFFFFFF;

TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);

end; 

  If AvailToCall >= 0 then

TotalFree := AvailToCall

else

if AvailToCall = -1 then

begin

TotalFree := $7FFFFFFF;

TotalFree := TotalFree * 2;

TotalFree := TotalFree + 1;

end

else begin

TotalFree := $7FFFFFFF;

TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);

end;

End; 

Function ExecuteOneFile(WorkDir, FileName, Params:String):Integer;

Begin

  FileName:=FileName+#0;

  WorkDir:=WorkDir+#0;

  Params:=Params+#0; 

  Result:=ShellExecute(0, 'open', @FileName[1], @Params[1], @WorkDir[1], SW_SHOWNORMAL);

End; 

Function GetExecuteError(ErrorCode:Integer):String;

Begin

  Result:='';

  If ErrorCode>32 Then Exit;

Case ErrorCode Of

    0                     : Result:='Системе не хватает памяти  или ресурсов';

ERROR_FILE_NOT_FOUND  : Result:='Файлненайден';

    ERROR_PATH_NOT_FOUND  : Result:='Путьненайден';

    ERROR_BAD_FORMAT      : Result:='Ошибкавформатефайла';

    SE_ERR_ACCESSDENIED   : Result:='Доступкфайлузакрыт';

    SE_ERR_ASSOCINCOMPLETE: Result:='Файловаяассоциацияневерна';

SE_ERR_DLLNOTFOUND    : Result:='Динамическая библиотека не  найдена';

    SE_ERR_NOASSOC        : Result:='Отсутствует приложение, связанное  с данным типом файла';

    SE_ERR_OOM            : Result:='Недостаточно памяти для  завершения операции';

    SE_ERR_SHARE          : Result:='Ошибка совместного доступа';

  Else

    Result:='Ошибка  при запуске программы';

End;

End; 

Function CopyOneFile(FromFile, ToFile:String; PrevCheck:Boolean):Integer;

Begin

  If PrevCheck Then

  Begin

    If FromFile=ToFile Then

    Begin

      Result:=F_ER_HIMSELF;

      Exit;

    End;

    If FileExists(ToFile) Then

    Begin

      Result:=F_ER_EXISTS;

      Exit;

    End; 
 

  End;