我不记得这是从哪里来的,但它有效。不幸的是,我不知道如何在此处添加带有图标的dcr文件。
更新:在torry.net上找到了它,还有很多其他执行相同操作的组件:
http://www.torry.net/pages.php?id=252
unit DiscMon;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, ShlObj;
type
TDiscMonitorThread = class(TThread)
private
FOnChange : TNotifyEvent;
FOnInvalid : TNotifyEvent;
FDirectory : string;
FFilters : integer;
FDestroyEvent,
FChangeEvent : THandle;
FMultipleChanges : boolean;
FSubTree : boolean;
procedure InformChange;
procedure InformInvalid;
procedure SetDirectory (const Value : string);
procedure SetFilters (Value : integer);
procedure SetMultipleChanges (Value : boolean);
procedure SetSubTree (Value : boolean);
protected
procedure Execute; override;
procedure Update;
public
constructor Create;
destructor Destroy; override;
property Directory : string read FDirectory write SetDirectory;
property Filters : integer read FFilters write SetFilters;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
property OnInvalid : TNotifyEvent read FOnInvalid write FOnInvalid;
property MultipleChanges : boolean read FMultipleChanges write SetMultipleChanges;
property SubTree : boolean read FSubTree write SetSubTree;
end;
TDiscMonitorDirStr = type string;
TMonitorFilter = (moFilename, moDirName, moAttributes, moSize,
moLastWrite, moSecurity);
TMonitorFilters = set of TMonitorFilter;
TDiscMonitor = class(TComponent)
private
FActive : boolean;
FMonitor : TDiscMonitorThread;
FFilters : TMonitorFilters;
FOnChange : TNotifyEvent;
FOnInvalid : TNotifyEvent;
FShowMsg : boolean;
function GetDirectory : TDiscMonitorDirStr;
function GetMultipleChanges : boolean;
function GetSubTree : boolean;
procedure SetActive (Value : boolean);
procedure SetDirectory (Value : TDiscMonitorDirStr);
procedure SetFilters (Value : TMonitorFilters);
procedure SetMultipleChanges (Value : boolean);
procedure SetSubTree (Value : boolean);
protected
procedure Change (Sender : TObject);
procedure Invalid (Sender : TObject);
public
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
procedure Close;
procedure Open;
property Thread : TDiscMonitorThread read FMonitor;
published
property Directory : TDiscMonitorDirStr read GetDirectory write SetDirectory;
property ShowDesignMsg : boolean read FShowMsg write FShowMsg default false;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
property OnInvalid : TNotifyEvent read FOnInvalid write FOnInvalid;
property Filters : TMonitorFilters read FFilters write SetFilters default [moFilename];
property MultipleChanges : boolean read GetMultipleChanges write SetMultipleChanges;
property SubTree : boolean read GetSubTree write SetSubTree default true;
property Active : boolean read FActive write SetActive default false;
end;
procedure Register;
implementation
constructor TDiscMonitorThread.Create;
begin
inherited Create (true);
FDestroyEvent := CreateEvent (nil, false, false, nil);
FChangeEvent := CreateEvent (nil, false, false, nil)
end;
destructor TDiscMonitorThread.Destroy;
begin
FOnChange := nil;
FOnInvalid := nil;
SetEvent (FDestroyEvent);
FDirectory := '';
inherited Destroy
end;
procedure TDiscMonitorThread.InformChange;
begin
if Assigned(FOnChange) then
FOnChange(Self)
end;
procedure TDiscMonitorThread.InformInvalid;
begin
if Assigned (FOnInvalid) then
FOnInvalid (Self)
end;
procedure TDiscMonitorThread.SetDirectory (const Value : string);
begin
if Value <> FDirectory then
begin
FDirectory := Value;
Update
end
end;
procedure TDiscMonitorThread.SetFilters (Value : integer);
begin
if Value <> FFilters then
begin
FFilters := Value;
Update
end
end;
procedure TDiscMonitorThread.SetMultipleChanges (Value : boolean);
begin
if Value <> FMultipleChanges then
FMultipleChanges := Value;
end;
procedure TDiscMonitorThread.SetSubTree (Value : boolean);
begin
if Value <> FSubTree then
begin
FSubtree := Value;
Update
end
end;
procedure TDiscMonitorThread.Update;
begin
if not Suspended then
SetEvent (FChangeEvent)
end;
procedure TDiscMonitorThread.Execute;
const
R : array [false..true] of BOOL = (BOOL (0), BOOL (1));
var
A : array [0..2] of THandle;
B : boolean;
begin
B := false;
A [0] := FDestroyEvent;
A [1] := FChangeEvent;
A [2] := FindFirstChangeNotification (PChar(FDirectory),R[fSubTree],FFilters);
repeat
if A [2] = INVALID_HANDLE_VALUE then
begin
Synchronize (InformInvalid);
case WaitForMultipleObjects(2,PWOHandleArray(@A),false,INFINITE)-WAIT_OBJECT_0 of
0 : B := true;
1 : A [2] := FindFirstChangeNotification (PChar(FDirectory),
R[fSubTree],FFilters)
end
end else
case WaitForMultipleObjects(3,PWOHandleArray(@A),false,INFINITE)-WAIT_OBJECT_0 of
0 : begin
FindCloseChangeNotification (A [2]);
B := true
end;
1 : begin
FindCloseChangeNotification (A [2]);
A [2] := FindFirstChangeNotification (PChar(FDirectory),
R[fSubTree],FFilters)
end;
2 : begin
Synchronize(InformChange);
if FMultipleChanges then
FindNextChangeNotification (A [2])
else
begin
FindCloseChangeNotification (A [2]);
A [2] := FindFirstChangeNotification (PChar(FDirectory),
R[fSubTree],FFilters);
end
end;
end
until B;
CloseHandle (FChangeEvent);
CloseHandle (FDestroyEvent)
end;
constructor TDiscMonitor.Create (AOwner : TComponent);
begin
inherited Create (AOwner);
FMonitor:=TDiscMonitorThread.Create;
FMonitor.OnChange:=Change;
FMonitor.OnInvalid:=Invalid;
Filters:=[moFilename];
MultipleChanges:=false;
SubTree:=false
end;
destructor TDiscMonitor.Destroy;
begin
FMonitor.Free;
inherited Destroy
end;
procedure TDiscMonitor.Change;
begin
if Assigned (FOnChange) then
FOnChange (Self)
else
if (csDesigning in ComponentState) and FShowMsg then
ShowMessage ('Change signalled')
end;
procedure TDiscMonitor.Invalid;
begin
if Assigned (FOnInvalid) then
FOnInvalid (Self)
else
if (csDesigning in ComponentState) and FShowMsg then
ShowMessage ('Invalid parameter signalled')
end;
procedure TDiscMonitor.Close;
begin
Active := false
end;
procedure TDiscMonitor.Open;
begin
Active := true
end;
procedure TDiscMonitor.SetActive (Value : boolean);
begin
if Value <> FActive then
begin
FActive := Value;
if Active then
begin
FMonitor.Resume;
FMonitor.Update
end else
FMonitor.Suspend
end
end;
function TDiscMonitor.GetDirectory : TDiscMonitorDirStr;
begin
Result := FMonitor.Directory
end;
function TDiscMonitor.GetMultipleChanges : boolean;
begin
Result := FMonitor.MultipleChanges
end;
function TDiscMonitor.GetSubTree : boolean;
begin
Result := FMonitor.SubTree
end;
procedure TDiscMonitor.SetDirectory (Value : TDiscMonitorDirStr);
begin
FMonitor.Directory := Value
end;
procedure TDiscMonitor.SetFilters (Value : TMonitorFilters);
const
XlatFileNotify : array [moFilename..moSecurity] of integer =
(FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,
FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,
FILE_NOTIFY_CHANGE_LAST_WRITE, FILE_NOTIFY_CHANGE_SECURITY);
var
L : TMonitorFilter;
I : integer;
begin
if Value <> FFilters then
if Value = [] then
ShowMessage ('Some filter condition must be set.')
else begin
FFilters := Value;
I := 0;
for L := moFilename to moSecurity do
if L in Value then
I := I or XlatFileNotify [L];
FMonitor.Filters := I;
end
end;
procedure TDiscMonitor.SetMultipleChanges (Value : boolean);
begin
FMonitor.MultipleChanges:=Value
end;
procedure TDiscMonitor.SetSubTree (Value : boolean);
begin
FMonitor.SubTree:=Value
end;
procedure Register;
begin
RegisterComponents ('Samples', [TDiscMonitor]);
end;
end.