FAQ VCL
Файлы и файловая система

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как узнать размер картинки (в пикселях) изображения в JPG-файле?

function ReadMWord( f: TFileStream ): Word;
type
  TMotorolaWord = record
    case byte of
      0: ( Value: Word );
      1: ( Byte1, Byte2: Byte );
    end;
var
  MW: TMotorolaWord;
begin
   f.Read( MW.Byte2, SizeOf( Byte ) );
   f.Read( MW.Byte1, SizeOf( Byte ) );
   Result := MW.Value;
end;

procedure GetJPGSize( const sFile: string; var wWidth, wHeight: Word );
const
  ValidSig: array[0..1] of byte = ( $FF, $D8 );
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
  Sig: array[0..1] of Byte;
  f: TFileStream;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  Len: word;
  ReadLen: LongInt;
begin
   FillChar( Sig, SizeOf( Sig ), #0 );
   f := TFileStream.Create( sFile, fmOpenRead );
   try
      ReadLen := f.Read( Sig[0], SizeOf( Sig ) );

      for x := Low( Sig ) to High( Sig ) do
         if Sig[x] <> ValidSig[x] then
            ReadLen := 0;

      if ReadLen > 0 then
      begin
         ReadLen := f.Read( Seg, 1 );
         while ( Seg = $FF ) and ( ReadLen > 0 ) do
         begin
            ReadLen := f.Read( Seg, 1 );
            if Seg <> $FF then
            begin
               if ( Seg = $C0 ) or ( Seg = $C1 ) then
               begin
                  ReadLen := f.Read( Dummy[0], 3 );
                  wHeight := ReadMWord( f );
                  wWidth := ReadMWord( f );
               end
               else
               begin
                  if not ( Seg in Parameterless ) then
                  begin
                     Len := ReadMWord( f );
                     f.Seek( Len-2, 1 );
                     f.Read( Seg, 1 );
                  end
                  else
                     Seg := $FF;
               end;
            end;
         end;
      end;
   finally
      f.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W, H: Word;
begin
   GetJPGSize( 'c:\photo.jpg', W, H );
   ShowMessage( Format( 'Width: %d, Height: %d', [W, H] ) );
end;


Как поставить знак ударения в имени файла?

// Программа должна поддерживать Unicode

function AddAccentToFilename( Path: WideString; Position: Word ): Boolean;
var
  W, W1, W2: WideString;
begin
   W := Copy( Path, LastDelimiter( '\', Path )+1, Length( Path ) );
   W1 := Copy( W, 1, Position );
   W2 := Copy( W, Position+1, Length( W ) );
   W := W1 + WideChar( 769 ) + W2;
   Result := MoveFileW( Pointer( Path ), Pointer( Copy( Path, 1, LastDelimiter( '\', Path ) ) + W ) );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if not AddAccentToFilename( Application.ExeName, 1 ) then
      ShowMessage( SysErrorMessage( GetLastError ) );
end;


Как удалить файл?

uses
  {...,} ShellAPI;

function Recycle(const FileName: string; Wnd: HWND): Boolean;
var
  FileOp: TSHFileOpStruct;
begin
  if Wnd = 0 then
    Wnd := Application.Handle;
  FileOp.Wnd := Wnd;
  FileOp.wFunc := FO_DELETE;
  FileOp.pFrom := PChar(FileName);
  FileOp.pTo := nil;
  FileOp.fFlags := FOF_ALLOWUNDO or FOF_NOERRORUI or FOF_SILENT or FOF_NOCONFIRMATION;
  FileOp.fAnyOperationsAborted := False;
  FileOp.hNameMappings := nil;
  FileOp.lpszProgressTitle := nil;
  Result := (SHFileOperation(FileOp) = NO_ERROR) and (not FileOp.fAnyOperationsAborted);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Recycle('d:\folder\1.txt'#0, Handle);
end;


Как определить, какие права есть у пользователей (домен\юзер) для файла/каталога?

uses
  AclAPI;

type
  PACL_SIZE_INFORMATION = ^_ACL_SIZE_INFORMATION;
  _ACL_SIZE_INFORMATION = record
    AceCount : DWORD;
    AclBytesInUse : DWORD;
    AclBytesFree : DWORD;
  end;
  ACL_SIZE_INFORMATION = _ACL_SIZE_INFORMATION;

  PACE_HEADER = ^_ACE_HEADER;
  _ACE_HEADER = record
    AceType : BYTE;
    AceFlags : BYTE;
    AceSize : WORD;
  end;
  ACE_HEADER = _ACE_HEADER;

  PACCESS_ALLOWED_ACE = ^_ACCESS_ALLOWED_ACE;
  _ACCESS_ALLOWED_ACE = record
    Header : ACE_HEADER;
    Mask : ACCESS_MASK;
    SidStart : DWORD;
  end;
  ACCESS_ALLOWED_ACE = _ACCESS_ALLOWED_ACE;

const  // ACE inherit flags
  OBJECT_INHERIT_ACE         = $1;
  CONTAINER_INHERIT_ACE      = $2;
  NO_PROPAGATE_INHERIT_ACE   = $4;
  INHERIT_ONLY_ACE           = $8;
  INHERITED_ACE              = $10;
  VALID_INHERIT_FLAGS        = $1F;
  SUCCESSFUL_ACCESS_ACE_FLAG = $40;
  FAILED_ACCESS_ACE_FLAG     = $80;

const
  FILE_READ_DATA        = $0001;
  FILE_WRITE_DATA       = $0002;
  FILE_APPEND_DATA      = $0004;
  FILE_READ_EA          = $0008;
  FILE_WRITE_EA         = $0010;
  FILE_EXECUTE          = $0020;
  FILE_READ_ATTRIBUTES  = $0080;
  FILE_WRITE_ATTRIBUTES = $0100;

  FILE_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $1FF;
  FILE_GENERIC_READ = ( STANDARD_RIGHTS_READ or FILE_READ_DATA or
    FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE );
  FILE_GENERIC_WRITE = ( STANDARD_RIGHTS_WRITE or FILE_WRITE_DATA or
    FILE_WRITE_ATTRIBUTES or FILE_WRITE_EA or FILE_APPEND_DATA or SYNCHRONIZE );
  FILE_GENERIC_EXECUTE = ( STANDARD_RIGHTS_EXECUTE or FILE_READ_ATTRIBUTES or
    FILE_EXECUTE or SYNCHRONIZE );

procedure AclCheck( const Value: BOOL; Ignore: DWORD = 0 );
begin
   if not Value then
      if GetLastError <> Ignore then
         RaiseLastOSError;
end;

function GetInfo( AName: string ): string;
var
  i, iLen, iLenDomain: DWORD;
  pSecurityDescriptor, pUserName, pDomain: string;
  lpbDaclPresent, lpbDaclDefaulted: BOOL;
  pDacl: PACL;
  pAce: Pointer;
  pAclInformation: ACL_SIZE_INFORMATION;
  peUse: SID_NAME_USE;
begin
   AclCheck( GetFileSecurity( PChar( AName ), DACL_SECURITY_INFORMATION,
             nil, 0, iLen ), ERROR_INSUFFICIENT_BUFFER );
   SetLength( pSecurityDescriptor, iLen );
   AclCheck( GetFileSecurity( PWideChar( AName ), DACL_SECURITY_INFORMATION,
             Pointer( pSecurityDescriptor ), iLen, iLen ) );
   AclCheck( GetSecurityDescriptorDACL( Pointer( pSecurityDescriptor ),
             lpbDaclPresent, pDacl, lpbDaclDefaulted ) );
   AclCheck( GetAclInformation( pDacl^, Pointer( @pAclInformation ),
             SizeOf( ACL_SIZE_INFORMATION ), AclSizeInformation ) );

   Result := '';
   for i := 0 to pAclInformation.AceCount-1 do
   begin
      AclCheck( GetAce( pDacl^, i, pAce ) );
      with ACCESS_ALLOWED_ACE( pAce^ ) do
      begin
         iLen := 0;
         iLenDomain := 0;
         AclCheck( LookupAccountSid( nil, @SidStart, nil, iLen, nil,
                   iLenDomain, peUse ), ERROR_INSUFFICIENT_BUFFER );
         SetLength( pUserName, iLen );
         SetLength( pDomain, iLenDomain );
         AclCheck( LookupAccountSid( nil, @SidStart, Pointer( pUserName ), iLen,
                   Pointer( pDomain ),  iLenDomain, peUse ) );
         SetLength( pUserName, iLen );
         SetLength( pDomain, iLenDomain );
         Result := Result + pDomain;
         if Length( pDomain ) > 0 then
            Result := Result + '\';
         Result := Result + pUserName + ':';

         if ( Header.AceFlags and OBJECT_INHERIT_ACE ) > 0 then
            Result := Result + '(OI)';
         if ( Header.AceFlags and CONTAINER_INHERIT_ACE ) > 0 then
            Result := Result + '(CI)';
         if ( Header.AceFlags and INHERIT_ONLY_ACE ) > 0 then
            Result := Result + '(IO)';

         if ( Mask and FILE_ALL_ACCESS ) = FILE_ALL_ACCESS then
            Result := Result + 'F';
         if ( Mask and FILE_GENERIC_READ ) = FILE_GENERIC_READ then
            Result := Result + 'R';
         if ( Mask and FILE_GENERIC_WRITE ) = FILE_GENERIC_WRITE then
            Result := Result + 'W';
         if ( Mask and FILE_GENERIC_EXECUTE ) = FILE_GENERIC_EXECUTE then
            Result := Result + 'E';

         Result := Result + #13;
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( GetInfo( 'c:\' ) );
end;


Как узнать размер картинки (в пикселях) изображения в PNG-файле?

function ReadMWord( f: TFileStream ): Word;
type
  TMotorolaWord = record
    case byte of
      0: ( Value: Word );
      1: ( Byte1, Byte2: Byte );
    end;
var
  MW: TMotorolaWord;
begin
   f.Read( MW.Byte2, SizeOf( Byte ) );
   f.Read( MW.Byte1, SizeOf( Byte ) );
   Result := MW.Value;
end;

procedure GetPNGSize( const sFile: string; var wWidth, wHeight: Word );
type
  TPNGSig = array[0..7] of Byte;
const
  ValidSig: TPNGSig = ( 137, 80, 78, 71, 13, 10, 26, 10 );
var
  Sig: TPNGSig;
  f: TFileStream;
  x: Integer;
begin
   FillChar( Sig, SizeOf( Sig ), #0 );
   f := TFileStream.Create( sFile, fmOpenRead );
   try
      f.Read( Sig[0], SizeOf( Sig ) );
      for x := Low( Sig ) to High( Sig ) do
         if Sig[x] <> ValidSig[x] then
            Exit;
      f.Seek( 18, 0 );
      wWidth := ReadMWord( f );
      f.Seek( 22, 0 );
      wHeight := ReadMWord( f );
   finally
      f.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W, H: Word;
begin
   GetPNGSize( 'c:\photo.png', W, H );
   ShowMessage( Format( 'Width: %d, Height: %d', [W, H] ) );
end;


Как узнать размер картинки (в пикселях) изображения в GIF-файле?

procedure GetGIFSize( const sFile: string; var wWidth, wHeight: Word );
type
  TGifHeader = record
    Signature: array [0..5] of AnsiChar;
    Width, Height: Word;
  end;
var
  Header: TGifHeader;
  fs: TFileStream;
begin
   FillChar( Header, SizeOf( TGifHeader ), #0 );
   wWidth := 0;
   wHeight := 0;

   try
      fs := TFileStream.Create( sFile, fmOpenRead or fmShareDenyWrite );
      with fs do
      begin
         Seek( 0, soFromBeginning );
         ReadBuffer( Header, SizeOf( TGifHeader ) );
      end;
      if ( AnsiUpperCase( Header.Signature ) = 'GIF89A' ) or
         ( AnsiUpperCase( Header.Signature ) = 'GIF87A' ) then
      begin
         wWidth  := Header.Width;
         wHeight := Header.Height;
      end;
   finally
      fs.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W, H: Word;
begin
    GetGIFSize( 'c:\photo.gif', W, H );
    ShowMessage( Format( 'Width: %d, Height: %d', [W, H] ) );
end;


Как переименовать файл/каталог?

// Способ первый
uses
  ShellAPI;

function RenameDir( DirFrom, DirTo: string ): Boolean;
var
  ShellInfo: TSHFileOpStruct;
begin
   with ShellInfo do
   begin
      Wnd := Application.Handle;
      wFunc := FO_RENAME;
      pFrom := PChar( DirFrom );
      pTo := PChar( DirTo );
      fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
                FOF_SILENT or FOF_NOCONFIRMATION;
   end;
   Result := SHFileOperation( ShellInfo ) = 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   // Переименование файла
   RenameDir( 'c:\test\test.txt', 'c:\test\test1.txt' );
   // Переименование каталога
   RenameDir( 'c:\test\', 'c:\test1\' );
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
   // Переименование файла
   MoveFile( 'c:\test\test.txt', 'c:\test\test1.txt' );
   // Переименование каталога
   MoveFile( 'c:\test1', 'c:\test' );
end;


Как определить, используется ли файл другим приложением эксклюзивно?

function FileIsUse( fName: string ): Boolean;
var
  HFileRes: HFILE;
begin
   Result := False;
   if not FileExists( fName ) then
      Exit;
   HFileRes := CreateFile( PChar( fName ), GENERIC_READ, 0, nil, OPEN_EXISTING,
                           FILE_ATTRIBUTE_NORMAL, 0 );
   Result := HFileRes = INVALID_HANDLE_VALUE;
   if not Result then
      CloseHandle( HFileRes );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if FileIsUse( 'c:\text.txt' ) then
      ShowMessage( 'Файл используется эксклюзивно' )
   else
      ShowMessage( 'Файл не используется эксклюзивно' );
end;


Как проверить соответствие файла PE-формату без запуска?

// Способ основан на-использованием функции WinAPI CreateFileMapping с флагом SEC_IMAGE.
// Такая комбинация сообщает системе, что проецируемый файл должен являться исполняемым,
// и, соответственно, память проекции надо подготовить соответствующим образом, с учетом
// заголовка и секций. Если файл не является корректным, например, повреждена структура
// секций или не соответствует заголовок, то CreateFileMapping вернет ошибку.

function CheckPEFile( FileName: string ): Boolean;
var
  hFile, hFileMapping: NativeUInt;
  flProtect: Cardinal;
  pMemory: Pointer;
begin
   Result := False;
   hFile := CreateFile( PChar( FileName ), GENERIC_READ, FILE_SHARE_READ, nil,
                        OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 );

   if hFile = INVALID_HANDLE_VALUE then
      Exit;

   // вся ФИШКА в SEC_IMAGE !!!
   flProtect := PAGE_READONLY or SEC_IMAGE;

   try
      hFileMapping := CreateFileMapping( hFile, nil, flProtect, 0, 0, nil );
      CloseHandle( hFile );
   except
      CloseHandle( hFile );
      Exit;
   end;

   if hFileMapping = 0 then
      Exit;

   try
      pMemory := MapViewOfFile( hFileMapping, FILE_MAP_READ, 0, 0, 0 );
      Result := pMemory <> nil;
      if Result then
         UnmapViewOfFile( pMemory );
   finally
      CloseHandle( hFileMapping );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   case CheckPEFile( 'd:\РАН\Creator\Win32\Release\Settings.xml' ) of
      True: ShowMessage( 'Файл соответствует PE-формату.' );
      False: ShowMessage( 'Файл не соответствует PE-формату.' );
   end;
end;


Как открыть для файла контекстное меню, как в проводнике?

uses
  ShlObj, ActiveX, ComObj;

procedure ShowSysPopup( aFile: string; x, y: integer; HND: HWND );
var
  Root: IShellFolder;
  ShellParentFolder: IShellFolder;
  chEaten,dwAttributes: ULONG;
  FilePIDL,ParentFolderPIDL: PItemIDList;
  CM: IContextMenu;
  Menu: HMenu;
  Command: LongBool;
  ICM2: IContextMenu2;

  ICI: TCMInvokeCommandInfo;
  ICmd: integer;
  P: TPoint;
begin
   // Get the Desktop IShellFolder interface
   OleCheck( SHGetDesktopFolder( Root ) );

   // Get the PItemIDList of the parent folder
   OleCheck( Root.ParseDisplayName( HND, nil,
      PWideChar( WideString( ExtractFilePath( aFile ) ) ),
      chEaten, ParentFolderPIDL, dwAttributes ) );

   // Get the IShellFolder Interface  of the Parent Folder
   OleCheck( Root.BindToObject( ParentFolderPIDL, nil, IShellFolder,
      ShellParentFolder ) );

   // Get the relative  PItemIDList of the File
   OleCheck( ShellParentFolder.ParseDisplayName( HND, nil,
      PWideChar( WideString( ExtractFileName( aFile ) ) ),
      chEaten, FilePIDL, dwAttributes ) );

   // Get the IContextMenu Interace for the file
   ShellParentFolder.GetUIObjectOf( HND, 1, FilePIDL, IID_IContextMenu, nil, CM );

   if CM = nil then
      Exit;

   P.X := X;
   P.Y := Y;

   Winapi.Windows.ClientToScreen( HND, P );

   Menu := CreatePopupMenu;

   try
      CM.QueryContextMenu( Menu, 0, 1, $7FFF, CMF_EXPLORE or CMF_CANRENAME );
      CM.QueryInterface( IID_IContextMenu2, ICM2 ); // To handle submenus.
      try
         Command := TrackPopupMenu( Menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or
            TPM_RIGHTBUTTON or TPM_RETURNCMD, p.X, p.Y, 0, HND, nil );
      finally
         ICM2 := nil;
      end;

      if Command then
      begin
         ICmd := LongInt( Command ) - 1;
         FillChar( ICI, SizeOf( ICI ), #0 );
         with ICI do
         begin
            cbSize := SizeOf( ICI );
            hWND := 0;
            lpVerb := MakeIntResourceA( ICmd );
            nShow := SW_SHOWNORMAL;
         end;
         CM.InvokeCommand(ICI);
      end;
   finally
      DestroyMenu( Menu );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowSysPopup( 'c:\Windows\System32\calc.exe', Button1.Left, Button1.Top, Handle );
end;

//initialization
//  OleInitialize( nil );

//finalization
//  OleUninitialize;

При использовании материала - ссылка на сайт обязательна