フォルダの圧縮属性をセット/リセットしても、そのフォルダに新規に作成するファイルのデフォルトの属性として適用されるだけで、既存のファイルには影響が及びません。そこで指定されたフォルダとそのサブフォルダ、含まれる全てのファイルをトラバースして圧縮属性をセット/リセットするようにします。
フォルダ/ファイルに圧縮属性を適用するたびにコールバック関数を呼び出して進行状況が呼び出し元に通知されるようになっています。コールバックが不要な場合は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やサンプルプログラム集 ファイルの圧縮属性の変更あたり。
0 件のコメント:
コメントを投稿