uses
Windows, SysUtils;
{$IFDEF VER200}
{$DEFINE ANONYMOUSMETHOD} // Anonymous method is available on Delphi 2009 or later
{$ENDIF}
type
{ Callback function declaration }
TNotifyCompressFunc = {$IFDEF ANONYMOUSMETHOD} reference to {$ENDIF}
procedure (const Filename: String;
Operation: TCompressOperation
{$IFNDEF ANONYMOUSMETHOD}; Param: DWORD {$ENDIF});
procedure CompressDirectory(const Dirname: String;
Operation: TCompressOperation;
IgnoreError: Boolean;
CallbackFunc: TNotifyCompressFunc
{$IFNDEF ANONYMOUSMETHOD}; Param: DWORD{$ENDIF});
{ Forward declarations }
procedure InternalCompressDirectory(const Dirname: String;
Operation: TCompressOperation;
IgnoreError: Boolean;
CallbackFunc: TNotifyCompressFunc
{$IFNDEF ANONYMOUSMETHOD}; Param: DWORD{$ENDIF}); forward;
{$WARN SYMBOL_PLATFORM OFF}
procedure CompressDirectory(const Dirname: String;
Operation: TCompressOperation;
IgnoreError: Boolean;
CallbackFunc: TNotifyCompressFunc
{$IFNDEF ANONYMOUSMETHOD}; Param: DWORD{$ENDIF});
var
Attr: DWORD;
Path: String;
begin
if VolumeCanCompress(Dirname) = False then
begin
{ This volume is not support compression }
Exit;
end;
Path := ExcludeTrailingPathDelimiter(Dirname);
{ Get directory attributes }
Attr := GetFileAttributes(PChar(Path));
if Attr = $FFFFFFFF then
begin
RaiseLastOSError;
end;
{ Compress or decompress directory }
InternalCompressDirectory(IncludeTrailingPathDelimiter(Dirname),Operation,
IgnoreError,CallbackFunc
{$IFNDEF ANONYMOUSMETHOD},Param{$ENDIF});
{ Compress or decompress }
if NeedChangeCompression(Operation,Attr) = True then
begin
if Assigned(CallbackFunc) then
begin
CallbackFunc(Path,Operation{$IFNDEF ANONYMOUSMETHOD},Param{$ENDIF});
end;
try
InternalCompressFile(Path,Operation,Attr);
except
if IgnoreError = False then
begin
raise;
end;
end;
end;
end;
procedure InternalCompressDirectory(const Dirname: String;
Operation: TCompressOperation;
IgnoreError: Boolean;
CallbackFunc: TNotifyCompressFunc
{$IFNDEF ANONYMOUSMETHOD}; Param: DWORD{$ENDIF});
var
SR: TSearchRec;
Path: String;
begin
if FindFirst(Dirname + '*.*',faAnyFile,SR) = 0 then
begin
try
repeat
{ Skip current and parent directory }
if (SR.Name = '.') or (SR.Name = '..') then
begin
Continue;
end;
Path := Dirname + SR.Name;
{ Compress or decompress directory (recursive call) }
if (SR.Attr and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
begin
InternalCompressDirectory(IncludeTrailingPathDelimiter(Path),
Operation,IgnoreError,CallbackFunc
{$IFNDEF ANONYMOUSMETHOD},Param{$ENDIF});
end;
{ Compress or decompress }
if NeedChangeCompression(Operation,SR.Attr) = True then
begin
if Assigned(CallbackFunc) then
begin
CallbackFunc(Path,Operation{$IFNDEF ANONYMOUSMETHOD},Param{$ENDIF});
end;
try
InternalCompressFile(Path,Operation,SR.Attr);
except
if IgnoreError = False then
begin
raise;
end;
end;
end;
until FindNext(SR) <> 0;
finally
FindClose(SR);
end;
end;
end;
{$WARN SYMBOL_PLATFORM ON}
procedure CallbackFunc(const Filename: String; Operation: TCompressOperation; Param: DWORD);
begin
TForm1(Param).Label1.Caption := 'Compressing: ' + Filename;
TForm1(Param).Refresh;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CompressDirectory(Edit1.Text,coCompress,CheckBox1.Checked,
CallbackFunc,DWORD(Self));
Label1.Caption := 'Finished.';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CompressDirectory(Edit1.Text,coCompress,CheckBox1.Checked,
procedure(const Filename: String; Operation: TCompressOperation)
begin
Label1.Caption := 'Compressing: ' + Filename;
Refresh;
end);
Label1.Caption := 'Finished.';
end;
function MakeCallbackFunc(Form: TForm1): TNotifyCompressFunc;
begin
Result :=
procedure(const Filename: String; Operation: TCompressOperation)
begin
case Operation of
coCompress:
begin
Form.Label1.Caption := 'Compressing: ' + Filename;
end;
coDecompress:
begin
Form.Label1.Caption := 'Decompressing: ' + Filename;
end;
end;
Form.Refresh;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CompressDirectory(Edit1.Text,coCompress,CheckBox1.Checked,
MakeCallbackFunc(Self));
Label1.Caption := 'Finished.';
end;
uses
Windows, SysUtils;
type
{ Compress operation }
TCompressOperation = (coCompress, coDecompress);
const
FSCTL_SET_COMPRESSION = $0009C040;
COMPRESSION_FORMAT_NONE = $00000000;
COMPRESSION_FORMAT_DEFAULT = $00000001;
procedure InternalCompressFile(const Filename: String;
Operation: TCompressOperation;
Attr: DWORD); forward;
function NeedChangeCompression(Operation: TCompressOperation;
Attr: DWORD): Boolean; forward;
{$WARN SYMBOL_PLATFORM OFF}
procedure CompressFile(const Filename: String; Operation: TCompressOperation);
var
Attr: DWORD;
begin
if VolumeCanCompress(Filename) = False then
begin
{ This volume is not support compression }
Exit;
end;
{ Get file attributes }
Attr := GetFileAttributes(PChar(Filename));
if Attr = $FFFFFFFF then
begin
RaiseLastOSError;
end;
if NeedChangeCompression(Operation,Attr) = True then
begin
{ Compress or decompress }
InternalCompressFile(Filename,Operation,Attr);
end;
end;
procedure InternalCompressFile(const Filename: String;
Operation: TCompressOperation;
Attr: DWORD);
const
CompressionFormat: array [TCompressOperation] of DWORD =
(COMPRESSION_FORMAT_DEFAULT, // Compress by default format
COMPRESSION_FORMAT_NONE); // Decompress
var
Handle: THandle;
InBuffer: DWORD;
BytesReturned: DWORD;
Access: DWORD;
Flags: DWORD;
begin
{ Flags for CreateFile }
Access := GENERIC_READ or GENERIC_WRITE;
if (Attr and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
Flags := FILE_ATTRIBUTE_NORMAL;
end
else
begin
Flags := FILE_FLAG_BACKUP_SEMANTICS;
end;
{ Reset read-only attribute }
if (Attr and FILE_ATTRIBUTE_READONLY) <> 0 then
begin
SetFileAttributes(PChar(Filename),Attr and not FILE_ATTRIBUTE_READONLY);
end;
try
{ Open file or directory }
Handle := CreateFile(PChar(Filename),Access,0,nil,OPEN_EXISTING,Flags,0);
if Handle = INVALID_HANDLE_VALUE then
begin
RaiseLastOSError;
end;
try
{ Compress or decompress }
InBuffer := CompressionFormat[Operation];
Win32Check(DeviceIoControl(Handle,FSCTL_SET_COMPRESSION,
@InBuffer,SizeOf(InBuffer),
nil,0,BytesReturned,nil));
finally
{ Close }
CloseHandle(Handle);
end;
finally
{ Restore read-only attribute }
if (Attr and FILE_ATTRIBUTE_READONLY) <> 0 then
begin
SetFileAttributes(PChar(Filename),
GetFileAttributes(PChar(Filename)) or
FILE_ATTRIBUTE_READONLY);
end;
end;
end;
function NeedChangeCompression(Operation: TCompressOperation;
Attr: DWORD): Boolean;
begin
Result := ((Ord(Operation) xor
Ord((Attr and FILE_ATTRIBUTE_COMPRESSED) <> 0)) = 0);
end;
{$WARN SYMBOL_PLATFORM ON}
uses
Windows, SysUtils;
{$WARN SYMBOL_PLATFORM OFF}
function VolumeCanCompress(const Filename: String): Boolean;
var
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
RootPath: String;
begin
{ Get root path }
RootPath := IncludeTrailingPathDelimiter(ExtractFileDrive(Filename));
{ Get volume information }
Win32Check(GetVolumeInformation(PChar(RootPath),nil,0,nil,
MaximumComponentLength,FileSystemFlags,
nil,0));
{ Check FS_FILE_COMPRESSION flag }
Result := ((FileSystemFlags and FS_FILE_COMPRESSION) <> 0);
end;
{$WARN SYMBOL_PLATFORM ON}
REGEDIT.EXE /e "<exportfile>" "<keyname>"
<exportfile> ... 出力ファイル名(拡張子.REG)
<keyname> ... 出力する最上位のキー名(HKEY_CURRENT_USER\...)