:: 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;
|
При использовании материала - ссылка на сайт обязательна
|
|