NTFSファイル圧縮機能を利用する(3)

NTFSで使用することができるファイル圧縮機能をプログラムから利用する方法の第三弾です。
フォルダの圧縮属性をセット/リセットしても、そのフォルダに新規に作成するファイルのデフォルトの属性として適用されるだけで、既存のファイルには影響が及びません。そこで指定されたフォルダとそのサブフォルダ、含まれる全てのファイルをトラバースして圧縮属性をセット/リセットするようにします。
フォルダ/ファイルに圧縮属性を適用するたびにコールバック関数を呼び出して進行状況が呼び出し元に通知されるようになっています。コールバックが不要な場合はnilを指定してください。またDelphi 2009ではコールバックに新機能の無名メソッドを使用するようにしてみました。

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}

パラメータIgnoreErrorは、Explorerで開いているフォルダを(圧縮属性を適用するために)CreateFileでオープンしたときにエラーになるため、これを無視するためのものです。
Delphi 2007およびそれ以前のバージョンでは以下のように呼び出します(フォーム上にButton1/Edit1/CheckBox1/Label1を配置)。

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;

これに対してDelphi 2009の無名メソッドを使用する場合は以下のように呼び出します。

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;

元ねたはNTFSの圧縮機能 - HEROPA's HomePageやサンプルプログラム集　ファイルの圧縮属性の変更あたり。