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\...)- VER<nnn>
- コンパイラバージョン
- RTLVersion<nnnn>
- ランタイムマイナーバージョン(仮)(Delphi 10.4.2以降)
- DCC
- (全ての環境で定義)
- CONSOLE
- コンソールアプリケーション
- NATIVECODE
- ネイティブコード(Delphi.net以降の.NET環境以外で定義)
- MSWINDOWS
- Windows(Kylix/macOS/iOS/Android/Linux以外で定義)
- WIN32
- Windows x86環境で定義(Delphi 6以降)
- WIN64
- Windows x64環境で定義(Delphi XE2以降)
- ARM64EC
- Windows on ARMのARM64EC環境で定義(Delphi 13.1以降)
- MACOS
- MacOS環境で定義(Delphi XE2以降)
- MACOS32
- MacOS 32bit環境で定義(Delphi XE2以降)
- MACOS64
- MacOS 64bit環境で定義(Delphi XE8以降)
- OSX
- OSX(MacOS)環境で定義(Delphi 11以降)
- OSX64
- OSX(MacOS)環境で定義(Delphi 11以降)
- POSIX
- MacOSを含むPOSIX環境で定義(Kykix/Delphi XE2以降)
- POSIX32
- MacOSを含むPOSIX 32bit環境で定義(Kykix/Delphi XE2以降)
- POSIX64
- MacOSを含むPOSIX 64bit環境で定義(Delphi XE2以降)
- IOS
- iOS(デバイス/シミュレータ)環境で定義(Delphi XE4以降)
- IOS32
- iOS 32bit環境で定義(Delphi XE8以降)
- IOS64
- iOS 64bit環境で定義(Delphi XE8以降)
- LINUX
- Linux環境で定義(Kylix/Delphi 10.2以降)
- LINUX32
- Linux 32bit環境で定義(Kylix/Delphi 10.2以降)
- LINUX64
- Linux 64bit環境で定義(Delphi 10.2以降)
- ANDROID
- Android環境で定義(Delphi XE5以降)
- ANDROID32
- Android 32bit環境で定義(Delphi XE8以降)
- ANDROID64
- Android 64bit環境で定義(Delphi 10.3.3以降)
- CLR
- .NET環境で定義
- CPU386
- i386以降のCPU
- CPUX86
- x86のCPU(Delphi XE2以降)
- CPUX64
- x64のCPU(Delphi XE2以降)
- CPUXARM
- ARMのCPU(Delphi XE4以降)
- CPUARM32
- 32bit版ARMのCPU(Delphi XE8以降)
- CPUARM64
- 64bit版ARMのCPU(Delphi XE8以降)
- CPU32BITS
- 32bitのCPU(Delphi XE8以降)
- CPU64BITS
- 64bitのCPU(Delphi XE8以降)
- ASSEMBLER
- アセンブラ構文(asm)を使用できるかどうか
- UNICODE
- Unicode環境で定義(Delphi 2009以降)
- CONDITIONALEXPRESSIONS
- 条件評価($IF指令)を使用できるかどうか
- ALIGN_STACK
- OS Xコンパイラやその他の(Linux)コンパイラなどの厳密なスタックアライメント要求がない環境で定義(Delphi XE2以降)
- PC_MAPPED_EXCEPTIONS
- 例外の巻き戻しにアドレスマップを使用するプラットフォーム用コンパイラで定義(Delphi XE2以降)
- PIC
- OS XのようにPIC(位置独立コード)が要求されるプラットフォームで定義(Delphi XE2以降)
- AUTOREFCOUNT
- ARC(Automatic Reference Counting)をサポートする環境で定義(Delphi XE4以降、Delphi 10.4 Sydneyですべてのコンパイラが未定義に)
- EXTERNALLINKER
- 外部リンカを使用する環境で定義(Delphi XE4以降)(obsoleted)
- NEXTGEN
- (LLVMベースの)"NEXTGEN"コンパイラで定義(Delphi XE4以降、Delphi 10.4 Sydneyですべてのコンパイラが未定義に)
- ELF
- 実行/オブジェクトファイルがELF形式の環境で定義(Delphi 10.2以降)
- UNDERSCOREIMPORTNAME
- インポートされた名前が"_"(アンダースコア)付きになる環境で定義(Delphi XE4以降)
- WEAKREF
- 弱い参照(weak reference)が有効な環境で定義(Delphi XE4以降)
- WEAKINSTREF
- 弱い参照がインスタンスに定義される環境で定義(Delphi XE4以降、Delphi 10.4 Sydneyですべてのコンパイラが未定義に)
- WEAKINTREF
- 弱い参照がインタフェースに定義される環境で定義(Delphi XE4以降)
- FRAMEWORK_VCL
- プロジェクトがVCLフレームワークを使用(Delphi 11.1以降)
- FRAMEWORK_FMX
- プロジェクトがFMXフレームワークを使用(Delphi 11.1以降)
- WEAK_NATIVEINT
- NativeInt/NativeUIntが型エイリアスの環境で定義(Delphi 12)
- BCB
- C++Builderで定義
- WINDOWS
- Win16環境で定義
- LLVM
- LLVMベースコンパイラで定義(Delphi 13.1以降)
- VER40
- Turbo Pascal 4.0
- VER50
- Turbo Pascal 5.0
- VER55
- Turbo Pascal 5.5
- VER60
- Turbo Pascal 6.0
- VER10
- Turbo Pascal for Windows 1.0
- VER15
- Turbo Pascal for Windows 1.5
- VER70
- Borland Pascal 7.0
- VER80
- Delphi 1
- VER90
- Delphi 2
- VER93
- C++Builder 1
- VER100
- Delphi 3
- VER110
- C++Builder 3
- VER120
- Delphi 4
- VER125
- C++Builder 4
- VER130
- Delphi 5, C++Builder 5
- VER140
- Delphi 6, C++Builder 6, Kylix 1, Kylix 2, Kylix 3
- VER150
- Delphi 7, 7.1
- VER160
- Delphi 8 for .NET, C#Builder
- VER170
- Delphi 2005, C++Builder 2005 (Ver9)
- VER180
- Delphi 2006, C++Builder 2006 (Ver10), Delphi 2007, C++Builder 2007 (Ver11)
- VER185
- Delphi 2007, C++Builder 2007 (Ver11)
- VER190
- Delphi 2007 for .NET (Ver11)
- VER200
- Delphi 2009, C++Builder 2009 (Ver12)
- VER210
- Delphi 2010, C++Builder 2010 (Ver14)
- VER220
- Delphi XE, C++Builder XE (Ver15)
- VER230
- Delphi XE2, C++Builder XE2 (Ver16)
- VER240
- Delphi XE3, C++Builder XE3 (Ver17)
- VER250
- Delphi XE4, C++Builder XE4 (Ver18)
- VER260
- Delphi XE5, C++Builder XE5, Appmethod 1.13 (Ver19)
- VER265
- Appmethod 1.13 (Ver19.5)
- VER270
- Delphi XE6, C++Builder XE6, Appmethod 1.14 (Ver20)
- VER280
- Delphi XE7, C++Builder XE7, Appmethod 1.15 (Ver21)
- VER290
- Delphi XE8, C++Builder XE8, Appmethod 1.16 (Ver22)
- VER300
- Delphi 10 Seattle, C++Builder 10 Seattle (Ver23)
- VER310
- Delphi 10.1 Berlin, C++Builder 10.1 Berlin (Ver24)
- VER320
- Delphi 10.2 Tokyo, C++Builder 10.2 Tokyo (Ver25)
- VER330
- Delphi 10.3 Rio, C++Builder 10.3 Rio (Ver26)
- VER340
- Delphi 10.4 Sydney, C++Builder 10.4 Sydney (Ver27)
- VER350
- Delphi 11 Alexandria, C++Builder 11 Alexandria (Ver28)
- VER360
- Delphi 12 Athens, C++Builder 12 Athens (Ver29)
- VER370
- Delphi 13 Florence, C++Builder 13 Florence (Ver37)
- RTLVersion1041
- Delphi 10.4.2
- RTLVersion1042
- Delphi 10.4.2
- RTLVersion111
- Delphi 11.1/11.2/11.3
- RTLVersion112
- Delphi 11.2/11.3
- RTLVersion113
- Delphi 11.3
- RTLVersion121
- Delphi 12.1/12.2/12.3
- RTLVersion122
- Delphi 12.2/12.3
- RTLVersion123
- Delphi 12.3