delphi 文件夹操作（监控）

delphi 监控文件系统

delphi 监控文件系统你是否想为你的Windows加上一双眼睛，察看使用者在机器上所做的各种操作（例如建立、删除文件；改变文件或目录名字）呢？

这里介绍一种利用Windows未公开函数实现这个功能的方法。

在Windows下有一个未公开函数SHChangeNotifyRegister可以把你的窗口添加到系统的系统消息监视链中，该函数在Delphi中的定义如下：

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;
lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

其中参数hWnd定义了监视系统操作的窗口得句柄，参数uFlags dwEventID定义监视操作参数，参数uMsg定义操作消息，参数cItems定义附加参数，参数lpps指定一个PIDLSTRUCT结构，该结构指定监视的目录。

当函数调用成功之后，函数会返回一个监视操作句柄，同时系统就会将hWnd指定的窗口加入到操作监视链中，当有文件操作发生时，系统会向hWnd发送uMsg指定的消息，我们只要在程序中加入该消息的处理函数就可以实现对系统操作的监视了。

如果要退出程序监视，就要调用另外一个未公开得函数SHChangeNotifyDeregister来取消程序监视。

下面是使用Delphi编写的具体程序实现范例，首先建立一个新的工程文件，然后在Form1中加入一个Button控件和一个Memo控件，

程序的代码如下：

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs ,shlobj,Activex, StdCtrls;

const
SHCNE_RENAMEITEM = $1;
SHCNE_CREATE = $2;
SHCNE_DELETE = $4;
SHCNE_MKDIR = $8;
SHCNE_RMDIR = $10;
SHCNE_MEDIAINSERTED = $20;
SHCNE_MEDIAREMOVED = $40;
SHCNE_DRIVEREMOVED = $80;
SHCNE_DRIVEADD = $100;
SHCNE_NETSHARE = $200;
SHCNE_NETUNSHARE = $400;
SHCNE_ATTRIBUTES = $800;
SHCNE_UPDATEDIR = $1000;
SHCNE_UPDATEITEM = $2000;
SHCNE_SERVERDISCONNECT = $4000;
SHCNE_UPDATEIMAGE = $8000;
SHCNE_DRIVEADDGUI = $10000;
SHCNE_RENAMEFOLDER = $20000;
SHCNE_FREESPACE = $40000;
SHCNE_ASSOCCHANGED = $8000000;
SHCNE_DISKEVENTS = $2381F;
SHCNE_GLOBALEVENTS = $C0581E0;
SHCNE_ALLEVENTS = $7FFFFFFF;
SHCNE_INTERRUPT = $80000000;
SHCNF_IDLIST = 0;
// LPITEMIDLIST
SHCNF_PATHA = $1;
// path name
SHCNF_PRINTERA = $2;
// printer friendly name
SHCNF_DWORD = $3;
// DWORD
SHCNF_PATHW = $5;
// path name
SHCNF_PRINTERW = $6;
// printer friendly name
SHCNF_TYPE = $FF;
SHCNF_FLUSH = $1000;
SHCNF_FLUSHNOWAIT = $2000;
SHCNF_PATH = SHCNF_PATHW;
SHCNF_PRINTER = SHCNF_PRINTERW;
WM_SHNOTIFY = $401;
NOERROR = 0;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
procedure WMShellReg(var Message:TMessage);message WM_SHNOTIFY; { Public declarations }
end;

type PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT;
SHNOTIFYSTRUCT = record
dwItem1 : PItemIDList;
dwItem2 : PItemIDList;
end;
Type PSHFileInfoByte=^SHFileInfoByte;
_SHFileInfoByte = record
hIcon :Integer;
iIcon :Integer;
dwAttributes : Integer;
szDisplayName : array [0..259] of char;
szTypeName : array [0..79] of char;
end;
SHFileInfoByte=_SHFileInfoByte;
Type PIDLSTRUCT = ^IDLSTRUCT;
_IDLSTRUCT = record
pidl : PItemIDList;
bWatchSubFolders : Integer;
end;
IDLSTRUCT =_IDLSTRUCT;

function SHNotify_Register(hWnd : Integer) : Bool;
function SHNotify_UnRegister:Bool;
function SHEventName(strPath1,strPath2:string;lParam:Integer):string;
Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall;external 'Shell32.dll' index 4;
Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;
Function SHGetFileInfoPidl(pidl : PItemIDList;dwFileAttributes : Integer;psfib : PSHFILEINFOBYTE;cbFileInfo : Integer;uFlags : Integer):Integer;stdcall;external 'Shell32.dll' name 'SHGetFileInfoA';
var
Form1: TForm1;
m_hSHNotify:Integer;
m_pidlDesktop : PItemIDList;

implementation

{$R *.dfm}

{ TForm1 }

function SHEventName(strPath1,strPath2:string;lParam:Integer):string;
var
sEvent:String;
begin
case lParam of //根据参数设置提示消息
SHCNE_RENAMEITEM: sEvent := '重命名文件'+strPath1+'为'+strpath2;
SHCNE_CREATE: sEvent := '建立文件 文件名：'+strPath1;
SHCNE_DELETE: sEvent := '删除文件 文件名：'+strPath1;
SHCNE_MKDIR: sEvent := '新建目录 目录名：'+strPath1;
SHCNE_RMDIR: sEvent := '删除目录 目录名：'+strPath1;
SHCNE_MEDIAINSERTED: sEvent := strPath1+'中插入可移动存储介质';
SHCNE_MEDIAREMOVED: sEvent := strPath1+'中移去可移动存储介质'+strPath1+' '+strpath2;
SHCNE_DRIVEREMOVED: sEvent := '移去驱动器'+strPath1;
SHCNE_DRIVEADD: sEvent := '添加驱动器'+strPath1;
SHCNE_NETSHARE: sEvent := '改变目录'+strPath1+'的共享属性';

SHCNE_ATTRIBUTES: sEvent := '改变文件目录属性 文件名'+strPath1;
SHCNE_UPDATEDIR: sEvent := '更新目录'+strPath1;
SHCNE_UPDATEITEM: sEvent := '更新文件 文件名：'+strPath1;
SHCNE_SERVERDISCONNECT: sEvent := '断开与服务器的连接'+strPath1+' '+strpath2;
SHCNE_UPDATEIMAGE: sEvent := 'SHCNE_UPDATEIMAGE';
SHCNE_DRIVEADDGUI: sEvent := 'SHCNE_DRIVEADDGUI';
SHCNE_RENAMEFOLDER: sEvent := '重命名文件夹'+strPath1+'为'+strpath2;
SHCNE_FREESPACE: sEvent := '磁盘空间大小改变';
SHCNE_ASSOCCHANGED: sEvent := '改变文件关联';
else
sEvent:='未知操作'+IntToStr(lParam);
end;
Result:=sEvent;
end;

function SHNotify_Register(hWnd : Integer) : Bool;
var
ps: pidlstruct;
begin
{$R-}
result := false;
if m_hshnotify = 0 then begin
//获取桌面文件夹的pidl
if shgetspecialfolderlocation(0, CSIDL_DESKTOP, m_pidldesktop) <> noerror then
form1.close;
if boolean(m_pidldesktop) then begin
new(ps);
try
ps.bwatchsubfolders := 1;
ps.pidl := m_pidldesktop;

// 利用shchangenotifyregister函数注册系统消息处理
m_hshnotify := shchangenotifyregister(hwnd, (shcnf_type or shcnf_idlist),
(shcne_allevents or shcne_interrupt),
wm_shnotify, 1, ps);
result := boolean(m_hshnotify);
finally
FreeMem(ps);
end;
end
else
// 如果出现错误就使用 cotaskmemfree函数来释放句柄
cotaskmemfree(m_pidldesktop);
end;
{$R+}
end;

function SHNotify_UnRegister:Bool;
begin
Result:=False;
If Boolean(m_hSHNotify) Then
//取消系统消息监视，同时释放桌面的Pidl
If Boolean(SHChangeNotifyDeregister(m_hSHNotify)) Then begin
{$R-}
m_hSHNotify := 0;
CoTaskMemFree(m_pidlDesktop);
Result := True;
{$R-}
End;
end;

procedure TForm1.WMShellReg(var Message: TMessage);
//file://系统消息处理函数
var
strPath1,strPath2:String;
charPath:array[0..259]of char;
pidlItem:PSHNOTIFYSTRUCT;
begin
pidlItem:=PSHNOTIFYSTRUCT(Message.wParam);
//file://获得系统消息相关得路径
SHGetPathFromIDList(pidlItem.dwItem1,charPath);
strPath1:=charPath;
SHGetPathFromIDList(pidlItem.dwItem2,charPath);
strPath2:=charPath;
Memo1.Lines.Add(SHEvEntName(strPath1,strPath2,Message.lParam)+chr(13)+chr(10));
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//在程序退出的同时删除监视
if Boolean(m_pidlDesktop) then
SHNotify_Unregister;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
m_hSHNotify:=0;
if SHNotify_Register(Form1.Handle) then begin //file://注册Shell监视
ShowMessage('Shell监视程序成功注册');
Button1.Enabled := False;
end
else
ShowMessage('Shell监视程序注册失败');
end;

end.

View Code

运行程序，点击“打开监视”按钮，如果出现一个显示“Shell监视程序成功注册”的对话框，说明Form1已经加入到系统操作监视链中了，你可以试着在资源管理器中建立、删除文件夹，移动文件等操作，你可以发现这些操作都被记录下来并显示在文本框中。

在上面的程序中多次使用到了一个PItemIDList的结构，这个数据结构指定Windows下得一个“项目”，在Windows下资源实现统一管理一个“项目”可以是一个文件或者一个文件夹，也可以是一个打印机等资源。另外一些API函数也涉及到了Shell(Windows外壳)操作，各位读者可以参考相应的参考资料。

由于使用到了Windows的未公开函数，没有相关得参考资料，所以有一些未知得操作（在Memo1中会显示“未知操作”）。如果哪位读者有兴趣， http://member.netease.com/～blackcat 有实现该功能的VB程序下载。

以上程序在Windows98、Windows2000、Delphi5下运行通过。

如果需要检测某个文件夹，可使用以下方法：

function TDyjPlatDirMonitor.RegisterDirMonitor(hWnd: Integer;
aPath: string): Boolean;
var
_vP : PWideChar;
_vPs : IDLSTRUCT;
begin
{$R-}
Result := False;
if FSHNotify = 0 then
begin
_vP := PWideChar(WideString(aPath));
FPathPidl := SHSimpleIDListFromPath(_vP);
if Boolean(FPathPidl) then
begin
_vPs.bWatchSubFolders := 1;
_vPs.pidl := FPathPidl;
FSHNotify := SHChangeNotifyRegister(hWnd,
(SHCNF_TYPE or SHCNF_IDLIST),
(SHCNE_ALLEVENTS or SHCNE_INTERRUPT),
WM_SHNOTIFY, 1, @_vPs);
Result := Boolean(FSHNotify);
end
else
CoTaskMemFree(FPathPidl);
end;
{$R+ }
end;

View Code

监控系统文件操作

这里介绍一种利用Windows未公开函数实现这个功能的方法。

在Windows下有一个未公开函数SHChangeNotifyRegister可以把你的窗口添加到系统的系统消息监视链中，该函数在Delphi中的定义如下：

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;
lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

如果要退出程序监视，就要调用另外一个未公开得函数SHChangeNotifyDeregister来取消程序监视。

下面是使用Delphi编写的具体程序实现范例，首先建立一个新的工程文件，然后在Form1中加入一个Button控件和一个Memo控件，

程序的代码如下：

unit ufrmMain; 

interface 

uses 
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
Dialogs ,shlobj, Activex, StdCtrls, 
Menus, 
uTbLogFile; 

const 
SHCNE_RENAMEITEM = $1; 
SHCNE_CREATE = $2; 
SHCNE_DELETE = $4; 
SHCNE_MKDIR = $8; 
SHCNE_RMDIR = $10; 
SHCNE_MEDIAINSERTED = $20; 
SHCNE_MEDIAREMOVED = $40; 
SHCNE_DRIVEREMOVED = $80; 
SHCNE_DRIVEADD = $100; 
SHCNE_NETSHARE = $200; 
SHCNE_NETUNSHARE = $400; 
SHCNE_ATTRIBUTES = $800; 
SHCNE_UPDATEDIR = $1000; 
SHCNE_UPDATEITEM = $2000; 
SHCNE_SERVERDISCONNECT = $4000; 
SHCNE_UPDATEIMAGE = $8000; 
SHCNE_DRIVEADDGUI = $10000; 
SHCNE_RENAMEFOLDER = $20000; 
SHCNE_FREESPACE = $40000; 
SHCNE_ASSOCCHANGED = $8000000; 
SHCNE_DISKEVENTS = $2381F; 
SHCNE_GLOBALEVENTS = $C0581E0; 
SHCNE_ALLEVENTS = $7FFFFFFF; 
SHCNE_INTERRUPT = $80000000; 
SHCNF_IDLIST = 0; 
// LPITEMIDLIST 
SHCNF_PATHA = $1; 
// path name 
SHCNF_PRINTERA = $2; 
// printer friendly name 
SHCNF_DWORD = $3; 
// DWORD 
SHCNF_PATHW = $5; 
// path name 
SHCNF_PRINTERW = $6; 
// printer friendly name 
SHCNF_TYPE = $FF; 
SHCNF_FLUSH = $1000; 
SHCNF_FLUSHNOWAIT = $2000; 
SHCNF_PATH = SHCNF_PATHW; 
SHCNF_PRINTER = SHCNF_PRINTERW; 
WM_SHNOTIFY = $401; 
NOERROR = 0; 

type 
TForm1 = class(TForm) 
mmo1: TMemo; 
Button1: TButton; 
procedure FormCreate(Sender: TObject); 
procedure FormClose(Sender: TObject; var Action: TCloseAction); 
procedure btn1Click(Sender: TObject); 
procedure FormDestroy(Sender: TObject); 
private 
WRITE_LOG : TRTLCriticalSection; 
FLogWriterSetupForm: TTbLogFile; 
public 
procedure WMShellReg(var Message:TMessage);message WM_SHNOTIFY; 
end; 

type 
PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT; 
SHNOTIFYSTRUCT = record 
dwItem1 : PItemIDList; 
dwItem2 : PItemIDList; 
end; 

Type 
PSHFileInfoByte=^SHFileInfoByte; 
_SHFileInfoByte = record 
hIcon :Integer; 
iIcon :Integer; 
dwAttributes : Integer; 
szDisplayName : array [0..259] of char; 
szTypeName : array [0..79] of char; 
end; 

SHFileInfoByte=_SHFileInfoByte; 

Type PIDLSTRUCT = ^IDLSTRUCT; 
_IDLSTRUCT = record 
pidl : PItemIDList; 
bWatchSubFolders : Integer; 
end; 

IDLSTRUCT = _IDLSTRUCT; 

function SHNotify_Register(hWnd : Integer) : Bool; 
function SHNotify_UnRegister:Bool; 
function SHEventName(strPath1,strPath2:string;lParam:Integer):string; 
Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall;external 'Shell32.dll' index 4; 
Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2; 
Function SHGetFileInfoPidl(pidl : PItemIDList;dwFileAttributes : Integer;psfib : PSHFILEINFOBYTE;cbFileInfo : Integer;uFlags : Integer):Integer;stdcall;external 'Shell32.dll' name 'SHGetFileInfoA'; 

var 
Form1: TForm1; 
m_hSHNotify:Integer; 
m_pidlDesktop : PItemIDList; 

implementation 

{$R *.dfm} 

function SHEventName(strPath1, strPath2: string; lParam: Integer): string; 
var 
sEvent:String; 
begin 
case lParam of //根据参数设置提示消息 
SHCNE_RENAMEITEM: sEvent := '重命名文件' + strPath1 + '为' + strpath2; 
SHCNE_CREATE: sEvent := '建立文件 文件名：' + strPath1; 
SHCNE_DELETE: sEvent := '删除文件 文件名：' + strPath1; 
SHCNE_MKDIR: sEvent := '新建目录 目录名：' + strPath1; 
SHCNE_RMDIR: sEvent := '删除目录 目录名：' + strPath1; 
SHCNE_MEDIAINSERTED: sEvent := strPath1 + '中插入可移动存储介质'; 
SHCNE_MEDIAREMOVED: sEvent := strPath1 + '中移去可移动存储介质' + strPath1 + ' '+strpath2; 
SHCNE_DRIVEREMOVED: sEvent := '移去驱动器' + strPath1; 
SHCNE_DRIVEADD: sEvent := '添加驱动器' + strPath1; 
SHCNE_NETSHARE: sEvent := '改变目录' + strPath1 + '的共享属性'; 

SHCNE_ATTRIBUTES: sEvent := '改变文件目录属性 文件名' + strPath1; 
SHCNE_UPDATEDIR: sEvent := '更新目录' + strPath1; 
SHCNE_UPDATEITEM: sEvent := '更新文件 文件名：' + strPath1; 
SHCNE_SERVERDISCONNECT: sEvent := '断开与服务器的连接' + strPath1 + ' ' + strpath2; 
SHCNE_UPDATEIMAGE: sEvent := 'SHCNE_UPDATEIMAGE'; 
SHCNE_DRIVEADDGUI: sEvent := 'SHCNE_DRIVEADDGUI'; 
SHCNE_RENAMEFOLDER: sEvent := '重命名文件夹' + strPath1 + '为' + strpath2; 
SHCNE_FREESPACE: sEvent := '磁盘空间大小改变'; 
SHCNE_ASSOCCHANGED: sEvent := '改变文件关联'; 
else 
sEvent := '未知操作' + IntToStr(lParam); 
end; 
Result := sEvent; 
end; 

function SHNotify_Register(hWnd: Integer): Bool; 
var 
ps: pidlstruct; 
begin 
{$R-} 
result := false; 
if m_hshnotify = 0 then 
begin 
//获取桌面文件夹的pidl 
if shgetspecialfolderlocation(0, CSIDL_DESKTOP, m_pidldesktop) <> noerror then 
form1.close; 
if boolean(m_pidldesktop) then begin 
new(ps); 
try 
ps.bwatchsubfolders := 1; 
ps.pidl := m_pidldesktop; 

// 利用shchangenotifyregister函数注册系统消息处理 
m_hshnotify := shchangenotifyregister(hwnd, (shcnf_type or shcnf_idlist), 
(shcne_allevents or shcne_interrupt), 
wm_shnotify, 1, ps); 
result := boolean(m_hshnotify); 
finally 
FreeMem(ps); 
end; 
end 
else 
begin 
// 如果出现错误就使用 cotaskmemfree函数来释放句柄 
cotaskmemfree(m_pidldesktop); 
end; 
end; 
{$R+} 
end; 

function SHNotify_UnRegister: Bool; 
begin 
Result := False; 
If Boolean(m_hSHNotify) Then 
begin 
//取消系统消息监视，同时释放桌面的Pidl 
If Boolean(SHChangeNotifyDeregister(m_hSHNotify)) Then begin 
{$R-} 
m_hSHNotify := 0; 
CoTaskMemFree(m_pidlDesktop); 
Result := True; 
{$R-} 
End; 
end; 
end; 

procedure TForm1.WMShellReg(var Message: TMessage); 
//file://系统消息处理函数 
var 
strPath1,strPath2:String; 
charPath:array[0..259]of char; 
pidlItem:PSHNOTIFYSTRUCT; 
begin 
pidlItem := PSHNOTIFYSTRUCT(Message.wParam); 
//file://获得系统消息相关得路径 
SHGetPathFromIDList(pidlItem.dwItem1, charPath); 
strPath1 := charPath; 
SHGetPathFromIDList(pidlItem.dwItem2, charPath); 
strPath2 := charPath; 

try 
EnterCriticalSection(WRITE_LOG); 
FLogWriterSetupForm.WriteLnLog(SHEvEntName(strPath1, strPath2, Message.lParam) + chr(13) + chr(10)); 
finally 
LeaveCriticalSection(WRITE_LOG); 
end; 
// mmo1.Lines.Add(SHEvEntName(strPath1,strPath2,Message.lParam)+chr(13)+chr(10)); 
end; 

{获得计算机名} 
function GetComputerName: string; 
var 
buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char; 
Size: Cardinal; 
begin 
Size := MAX_COMPUTERNAME_LENGTH + 1; 
Windows.GetComputerName(@buffer, Size); 
Result := strpas(buffer); 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
Caption := GetComputerName; 

InitializeCriticalSection(WRITE_LOG); 
FLogWriterSetupForm := TTbLogFile.Create(nil); 
FLogWriterSetupForm.AutoRenameByDay := True; 
FLogWriterSetupForm.Open(ExtractFilePath(ParamStr(0)) + ' 操作.log', otAppend); 
end; 

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
//在程序退出的同时删除监视 
if Boolean(m_pidlDesktop) then 
SHNotify_Unregister; 
end; 

procedure TForm1.btn1Click(Sender: TObject); 
begin 
m_hSHNotify:=0; 
if SHNotify_Register(Form1.Handle) then begin //file://注册Shell监视 
ShowMessage('Shell监视程序成功注册'); 
Button1.Enabled := False; 
end 
else 
ShowMessage('Shell监视程序注册失败'); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
DeleteCriticalSection(WRITE_LOG); 
FreeAndNil(FLogWriterSetupForm); 
end; 

end.

View Code

以上程序在Windows98、Windows2000、Delphi5下运行通过。

delphi监控文件夹

(******************************************
  文件和目录监控
  当磁盘上有文件或目录操作时，产生事件
  使用方法：
 
  开始监控: PathWatch(Self.Handle, 'C:FtpFolder');
  解除监控：PathWatch(-1);
 
  在窗体中加消息监听
  private
    { Private declarations }
    procedure MsgListern(var Msg:TMessage);message WM_SHNOTIFY;
 
  实现：
  procedure TForm1.MsgListern(var Msg:TMessage);
  begin
    PathWatch(Msg,procedure(a,s1,s2:String) begin
      Log('文件事件是：'  +a);
      Log('文件名称是：'  +s1);
      Log('另外的参数是：'+s2);
    end);
  end;
 
******************************************)
unit PathWatch;
 
interface
 
uses
  Winapi.Messages, System.SysUtils, FMX.Types, FMX.Platform.Win, WinAPI.ShlObj,
  Winapi.ActiveX, WinApi.Windows, VCL.Dialogs
  ;
 
const
  WM_SHNOTIFY = $401;
 
type
  PIDLSTRUCT = ^IDLSTRUCT;
  _IDLSTRUCT = record
    pidl : PItemIDList;
    bWatchSubFolders : Integer;
  end;
  IDLSTRUCT =_IDLSTRUCT;
type
  PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT;
  SHNOTIFYSTRUCT = record
    dwItem1 : PItemIDList;
    dwItem2 : PItemIDList;
  end;
 
Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall;
external 'Shell32.dll' index 4;
 
Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;lpps:PIDLSTRUCT):integer;stdcall;
external 'Shell32.dll' index 2;
 
function PathWatch(hWND: Integer      ; Path:String=''):Boolean; overload;
function PathWatch(hWND: TWindowHandle; Path:String=''):Boolean; overload;
function PathWatch(var Msg: TMessage; callback: TProc<String,String,String>):Boolean; overload;
 
var
  g_HSHNotify   : Integer;
  g_pidlDesktop : PItemIDList;
  g_WatchPath   : String;
 
implementation
 
function PathWatch(hWND: Integer; Path:String=''):Boolean;
var
  ps:PIDLSTRUCT;
begin
  result:=False;
  Path:=Path.Replace('/','');
  if(hWnd>=0) then begin  //  开始监控
    g_WatchPath:=Path.ToUpper;
 
    if g_HSHNotify = 0 then begin
      SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, g_pidlDesktop);
      if Boolean(g_pidlDesktop) then begin
        getmem(ps,sizeof(IDLSTRUCT));
        ps.bWatchSubFolders := 1;
        ps.pidl := g_pidlDesktop;
        g_HSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT),WM_SHNOTIFY, 1, ps);
        Result := Boolean(g_HSHNotify);
      end else CoTaskMemFree(g_pidlDesktop);
    end;
  end else begin  //  解除监控
    if boolean(g_HSHNotify) then if Boolean(SHChangeNotifyDeregister(g_HSHNotify)) then begin
      g_HSHNotify := 1;
      CoTaskMemFree(g_pidlDesktop);
      result := True;
    end;
  end;
end;
 
function PathWatch(hWND: TWindowHandle; Path:String=''):Boolean;
begin
  PathWatch(FmxHandleToHWND(hWND),Path);  //  FireMonkey的窗体不接受处理Windows消息
end;
 
function PathWatch(var Msg: TMessage; callback:TProc<String,String,String>):Boolean;
var
  a, s1,s2  : String;
  buf       : array[0..MAX_PATH] of char;
  pidlItem  : PSHNOTIFYSTRUCT;
begin
  pidlItem :=PSHNOTIFYSTRUCT(Msg.WParam);
  SHGetPathFromIDList(pidlItem.dwItem1, buf); s1 := buf;
  SHGetPathFromIDList(pidlItem.dwItem2, buf); s2 := buf;
  a:='';
  case Msg.LParam of
//    SHCNE_RENAMEITEM      : a := '重命名'       ;
    SHCNE_CREATE          : a := '建立文件'     ;
//    SHCNE_DELETE          : a := '删除文件'     ;
//    SHCNE_MKDIR           : a := '新建目录'     ;
//    SHCNE_RMDIR           : a := '删除目录'     ;
//    SHCNE_ATTRIBUTES      : a := '改变属性'     ;
//    SHCNE_MEDIAINSERTED   : a := '插入介质'     ;
//    SHCNE_MEDIAREMOVED    : a := '移去介质'     ;
//    SHCNE_DRIVEREMOVED    : a := '移去驱动器'   ;
//    SHCNE_DRIVEADD        : a := '添加驱动器'   ;
//    SHCNE_NETSHARE        : a := '改变共享'     ;
//    SHCNE_UPDATEDIR       : a := '更新目录'     ;
//    SHCNE_UPDATEITEM      : a := '更新文件'     ;
//    SHCNE_SERVERDISCONNECT: a := '断开连接'     ;
//    SHCNE_UPDATEIMAGE     : a := '更新图标'     ;
//    SHCNE_DRIVEADDGUI     : a := '添加驱动器'   ;
//    SHCNE_RENAMEFOLDER    : a := '重命名文件夹' ;
//    SHCNE_FREESPACE       : a := '磁盘空间改变' ;
//    SHCNE_ASSOCCHANGED    : a := '改变文件关联' ;
//  else                      a := '其他操作'     ;
 
  end;
  result := True;
  if( (a<>'') and (Assigned(callback)) and (s1.ToUpper.StartsWith(g_WatchPath))) and (not s1.Contains('_plate')) then
  begin
    callback(a,s1,g_WatchPath);
  end;
end;
 
 
end.
 调用：

PathWatch(self.Handle, DM.Config.O['Local'].S['PhotoPath']);

窗体中需要消息事件触发：

procedure MsgListern(var Msg: TMessage); message WM_SHNOTIFY;     // 触发监听事件

procedure TFormMain.MsgListern(var Msg: TMessage);
begin
  PathWatch(Msg, Procedure(act,fn,s2: string) begin
    if(act='建立文件') then begin
      if SecondsBetween(now(), PrePostTime) >= 5 then    //两个时间之间相差的秒数
      begin
       // 这里处理监控到后   要响应的事情
      end;
    end;
  end);
end;

View Code

监控指定文件夹

delphi XE + XP 下测试通过
 
O2DirSpy.pas    (该单元获取自网络)
[delphi]  
{====================================================================}  
{   TOxygenDirectorySpy Component, v1.6 c 2000-2001 Oxygen Software  }  
{--------------------------------------------------------------------}  
{          Written by Oleg Fyodorov, delphi@oxygensoftware.com       }  
{                  http://www.oxygensoftware.com                     }  
{====================================================================}  
  
unit O2DirSpy;  
  
interface  
  
  uses Classes, Controls, Windows, SysUtils, ShellApi, Dialogs, Messages, FileCtrl;  
  
  type  
    TDirectoryChangeType = (ctNone, ctAttributes, ctSize, ctCreationTime, ctLastModificationTime, ctLastAccessTime, ctLastTime, ctCreate, ctRemove);  
  
    TOxygenDirectorySpy = class;  
  
    TDirectoryChangeRecord = record  
      Directory : String;  
      FileFlag : Boolean; // When True, ChangeType applies to a file; False - ChangeType applies to Directory  
      Name : String; // Name of changed file/directory  
      OldTime, NewTime : TDateTime;  // Significant only when ChangeType is one of ctCreationTime, ctLastModificationTime, ctLastAccessTime, ctLastTime  
      OldAttributes, NewAttributes : DWord; // Significant only when ChangeType is ctAttributes  
      OldSize, NewSize : DWord; // Significant only when ChangeType is ctSize  
      ChangeType : TDirectoryChangeType; // Describes a change type (creation, removing etc.)  
    end;  
  
    TSpySearchRec = record  
      Time: Integer;  
      Size: Integer;  
      Attr: Integer;  
      dwFileAttributes: DWORD;  
      ftCreationTime: TFileTime;  
      ftLastAccessTime: TFileTime;  
      ftLastWriteTime: TFileTime;  
      nFileSizeHigh: DWORD;  
      nFileSizeLow: DWORD;  
    end;  
  
    TFileData = class  
      private  
        FSearchRec : TSpySearchRec;  
        Name: TFileName;  
        FFound : Boolean;  
      public  
        constructor Create;  
        procedure Free;  
    end;  
  
    TFileDataList = class(TStringList)  
      private  
        function NewFileData(const FileName : String; sr : TSearchRec) : TFileData;  
        function GetFoundCount : Integer;  
      public  
        property FoundCount : Integer read GetFoundCount;  
  
        destructor Destroy; override;  
        function AddFileData(FileData : TFileData) : Integer;  
        function AddSearchRec(const Directory : String; sr : TSearchRec) : Integer;  
        procedure Delete(Index : Integer); override;  
        procedure Clear; override;  
        procedure SetFound(Value : Boolean);  
    end;  
  
    TReadDirChangesThread = class(TThread)  
    private  
      FOwner           : TOxygenDirectorySpy;  
      FDirectories     : TStringList;  
      FHandles         : TList;  
      FChangeRecord    : TDirectoryChangeRecord;  
      FFilesData,  
      FTempFilesData   : TFileDataList;  
      pHandles         : PWOHandleArray;  
      procedure ReleaseHandle;  
      procedure AllocateHandle;  
      procedure ReadDirectories(DestData : TFileDataList);  
      procedure CompareSearchRec(var srOld, srNew : TSpySearchRec);  
    protected  
      procedure Execute; override;  
      procedure Notify;  
    public  
      constructor Create(Owner : TOxygenDirectorySpy);  
      destructor Destroy; override;  
      procedure Reset;  
    end;  
  
    TChangeDirectoryEvent = procedure (Sender : TObject; ChangeRecord : TDirectoryChangeRecord) of object;  
  
    TOxygenDirectorySpy = class(TComponent)  
      private  
        FThread : TReadDirChangesThread;  
        FEnabled,  
        FWatchSubTree : Boolean;  
        FDirectories : TStrings;  
        FOnChangeDirectory : TChangeDirectoryEvent;  
  
        procedure SetEnabled(const Value : Boolean);  
        procedure CheckDirectories;  
        procedure SetDirectories(const Value : TStrings);  
        procedure SetWatchSubTree(const Value : Boolean);  
      protected  
        procedure DoChangeDirectory(ChangeRecord : TDirectoryChangeRecord);  
      published  
        property Enabled : Boolean read FEnabled write SetEnabled;  
        property Directories : TStrings read FDirectories write SetDirectories;  
        property WatchSubTree : Boolean read FWatchSubTree write SetWatchSubTree;  
        property OnChangeDirectory : TChangeDirectoryEvent read FOnChangeDirectory write FOnChangeDirectory;  
      public  
        constructor Create(AOwner : TComponent); override;  
        destructor Destroy; override;  
    end;  
  
    function ChangeRecord2String(ChangeRecord : TDirectoryChangeRecord) : String;  
  
    procedure Register;  
  
implementation  
  
function ChangeRecord2String(ChangeRecord : TDirectoryChangeRecord) : String;  
  var s : String;  
begin  
  Result := 'No changes';  
  if ChangeRecord.FileFlag then s := 'File ' else s := 'Directory ';  
  s := s + '"' + ChangeRecord.Name + '"';  
  case ChangeRecord.ChangeType of  
    ctAttributes           : Result := s + ' attributes are changed. Old: ' + IntToHex(ChangeRecord.OldAttributes,8) + ', New: ' + IntToHex(ChangeRecord.NewAttributes,8);  
    ctSize                 : Result := s + ' size is changed. Old: ' + IntToStr(ChangeRecord.OldSize) + ', New: ' + IntToStr(ChangeRecord.NewSize);  
    ctCreationTime         : Result := s + ' creation time is changed. Old: ' + DateTimeToStr(ChangeRecord.OldTime) + ', New: ' + DateTimeToStr(ChangeRecord.NewTime);  
    ctLastModificationTime : Result := s + ' last modification time is changed. Old: ' + DateTimeToStr(ChangeRecord.OldTime) + ', New: ' + DateTimeToStr(ChangeRecord.NewTime);  
    ctLastAccessTime       : Result := s + ' last access time is changed. Old: ' + DateTimeToStr(ChangeRecord.OldTime) + ', New: ' + DateTimeToStr(ChangeRecord.NewTime);  
    ctLastTime             : Result := s + ' time is changed. Old: ' + DateTimeToStr(ChangeRecord.OldTime) + ', New: ' + DateTimeToStr(ChangeRecord.NewTime);  
    ctCreate               : Result := s + ' is created';  
    ctRemove               : Result := s + ' is deleted';  
  end;  
end;  
  
function  SameSystemTime(Time1, Time2 : TSystemTime) : Boolean;  
begin  
  Result := ((Time1.wYear = Time2.wYear) and (Time1.wMonth = Time2.wMonth) and (Time1.wDay = Time2.wDay) and (Time1.wHour = Time2.wHour) and (Time1.wMinute = Time2.wMinute) and (Time1.wSecond = Time2.wSecond) and (Time1.wMilliseconds = Time2.wMilliseconds));  
end;  
  
function ReplaceText(s, SourceText, DestText: String):String;  
  var st,res:string;  
      i:Integer;  
begin  
  ReplaceText:='';  
  if ((s='') or (SourceText='')) then Exit;  
  st:=s;  
  res:='';  
  i:=Pos(SourceText,s);  
  while (i>0) do  
  begin  
    res:=res+Copy(st,1,i-1)+DestText;  
    Delete(st,1,(i+Length(SourceText)-1));  
    i:=Pos(SourceText,st);  
  end;  
  res:=res+st;  
  ReplaceText:=res;  
end;  
  
  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
// TFileData  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
constructor TFileData.Create;  
begin  
  inherited Create;  
  Name := '';  
  FillChar(FSearchRec,SizeOf(FSearchRec),0);  
  FFound := False;  
end;  
  
procedure TFileData.Free;  
begin  
  Name := '';  
  //Finalize(FSearchRec);  
  inherited Free;  
end;  
  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
//  TFileDataList  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
destructor TFileDataList.Destroy;  
begin  
  Clear;  
  inherited Destroy;;  
end;  
  
function TFileDataList.NewFileData(const FileName : String; sr : TSearchRec) : TFileData;  
begin  
  Result := TFileData.Create;  
  Result.Name := FileName;  
  with Result.FSearchRec do begin  
    Time := sr.Time;  
    Size := sr.Size;  
    Attr := sr.Attr;  
    dwFileAttributes := sr.FindData.dwFileAttributes;  
    ftCreationTime := sr.FindData.ftCreationTime;  
    ftLastAccessTime := sr.FindData.ftLastAccessTime;  
    ftLastWriteTime := sr.FindData.ftLastWriteTime;  
    nFileSizeHigh := sr.FindData.nFileSizeHigh;  
    nFileSizeLow := sr.FindData.nFileSizeLow;  
  end;  
end;  
  
function TFileDataList.GetFoundCount : Integer;  
  var i : Integer;  
begin  
  Result := 0;  
  for i := 1 to Count do if TFileData(Objects[i-1]).FFound then Inc(Result);  
end;  
  
function TFileDataList.AddFileData(FileData : TFileData) : Integer;  
  var fd : TFileData;  
begin  
  fd := TFileData.Create;  
  fd.Name := FileData.Name;  
  fd.FSearchRec := FileData.FSearchRec;  
  Result := AddObject(fd.Name, fd);  
end;  
  
function TFileDataList.AddSearchRec(const Directory : String; sr : TSearchRec) : Integer;  
  var FileName : String;  
begin  
  if (Directory <> '') then FileName := ReplaceText(Directory + '' + sr.Name,'\','') else FileName := sr.Name;  
  Result := AddObject(FileName, NewFileData(FileName, sr));  
end;  
  
procedure TFileDataList.Delete(Index : Integer);  
begin  
  TFileData(Objects[Index]).Free;  
  inherited Delete(Index);  
end;  
  
procedure TFileDataList.Clear;  
begin  
  while (Count > 0) do Delete(0);  
  inherited Clear;  
end;  
  
procedure TFileDataList.SetFound(Value : Boolean);  
  var i : Integer;  
begin  
  for i := 1 to Count do TFileData(Objects[i-1]).FFound := Value;  
end;  
  
function CompareMem(fpBlock1, fpBlock2: Pointer; Size: Cardinal): Boolean; assembler;  
asm  
        PUSH    ESI  
        PUSH    EDI  
        MOV     ESI,fpBlock1  
        MOV     EDI,fpBlock2  
        MOV     ECX,Size  
        MOV     EDX,ECX  
        XOR     EAX,EAX  
        AND     EDX,3  
        SHR     ECX,2  
        REPE    CMPSD  
        JNE     @@2  
        MOV     ECX,EDX  
        REPE    CMPSB  
        JNE     @@2  
@@1:    INC     EAX  
@@2:    POP     EDI  
        POP     ESI  
end;  
  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
//       TReadDirChangesThread  
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
procedure TReadDirChangesThread.CompareSearchRec(var srOld, srNew : TSpySearchRec);  
  var tt,nt,ot : TSystemTime;  
      //sro,srn : TSpySearchRec;  
begin  
  FChangeRecord.ChangeType := ctNone;  
  if CompareMem(@srOld,@srNew, SizeOf(TSpySearchRec)) then Exit;  
  if (srOld.Time <> srNew.Time) then begin  
    FChangeRecord.ChangeType := ctLastTime;  
    FChangeRecord.OldTime := FileDateToDateTime(srOld.Time);  
    FChangeRecord.NewTime := FileDateToDateTime(srNew.Time);  
    srOld.Time := srNew.Time;  
    Exit;  
  end  
  else if (srOld.Size <> srNew.Size) then begin  
    FChangeRecord.ChangeType := ctSize;  
    FChangeRecord.OldSize := srOld.Size;  
    FChangeRecord.NewSize := srNew.Size;  
    srOld.Size := srNew.Size;  
    Exit;  
  end  
  else if (srOld.Attr <> srNew.Attr) or (srOld.dwFileAttributes <> srNew.dwFileAttributes) then begin  
    FChangeRecord.ChangeType := ctAttributes;  
    FChangeRecord.OldAttributes := srOld.dwFileAttributes;  
    FChangeRecord.NewAttributes := srNew.dwFileAttributes;  
    srOld.dwFileAttributes := srNew.dwFileAttributes;  
    srOld.Attr := srNew.Attr;  
    Exit;  
  end  
  else begin  
    FileTimeToSystemTime(srNew.ftCreationTime,nt);  
    SystemTimeToTzSpecificLocalTime(nil,nt,tt);  
    nt := tt;  
    FileTimeToSystemTime(srOld.ftCreationTime,ot);  
    SystemTimeToTzSpecificLocalTime(nil,ot,tt);  
    ot := tt;  
    if not SameSystemTime(nt,ot) then begin  
      FChangeRecord.ChangeType := ctCreationTime;  
      FChangeRecord.OldTime := SystemTimeToDateTime(ot);  
      FChangeRecord.NewTime := SystemTimeToDateTime(nt);  
      srOld.ftCreationTime := srNew.ftCreationTime;  
      Exit;  
    end  
    else begin  
      FileTimeToSystemTime(srNew.ftLastAccessTime,nt);  
      SystemTimeToTzSpecificLocalTime(nil,nt,tt);  
      nt := tt;  
      FileTimeToSystemTime(srOld.ftLastAccessTime,ot);  
      SystemTimeToTzSpecificLocalTime(nil,ot,tt);  
      ot := tt;  
      if not SameSystemTime(nt,ot) then begin  
        FChangeRecord.ChangeType := ctLastAccessTime;  
        FChangeRecord.OldTime := SystemTimeToDateTime(ot);  
        FChangeRecord.NewTime := SystemTimeToDateTime(nt);  
        srOld.ftLastAccessTime := srNew.ftLastAccessTime;  
        Exit;  
      end  
      else begin  
        FileTimeToSystemTime(srNew.ftLastWriteTime,nt);  
        SystemTimeToTzSpecificLocalTime(nil,nt,tt);  
        nt := tt;  
        FileTimeToSystemTime(srOld.ftLastWriteTime,ot);  
        SystemTimeToTzSpecificLocalTime(nil,ot,tt);  
        ot := tt;  
        if not SameSystemTime(nt,ot) then begin  
          FChangeRecord.ChangeType := ctLastModificationTime;  
          FChangeRecord.OldTime := SystemTimeToDateTime(ot);  
          FChangeRecord.NewTime := SystemTimeToDateTime(nt);  
          srOld.ftLastWriteTime := srNew.ftLastWriteTime;  
          Exit;  
        end;  
      end;  
    end;  
  end;  
end;  
  
procedure TReadDirChangesThread.Execute;  
  var i, Index : Integer;  
      R : DWord;  
      fd : TFileData;  
begin  
  while not Terminated do try  
    if (FDirectories.Count = 0) or (not FOwner.Enabled) then Sleep(0)  
    else begin  
      R := WaitForMultipleObjects(FHandles.Count,pHandles,False,200);  
      if (R < (WAIT_OBJECT_0 + DWord(FHandles.Count))) then begin  
        FillChar(FChangeRecord,SizeOf(FChangeRecord),0);  
        FFilesData.SetFound(False);  
        FTempFilesData.Clear;  
        ReadDirectories(FTempFilesData);  
        while (FTempFilesData.Count > 0) do begin  
          fd := TFileData(FTempFilesData.Objects[0]);  
          // New file/directory is created  
          if not FFilesData.Find(fd.Name,Index) then begin  
            Index := FFilesData.AddFileData(fd);  
            TFileData(FFilesData.Objects[Index]).FFound := True;  
            FChangeRecord.ChangeType := ctCreate;  
            FChangeRecord.Name := fd.Name;  
            FChangeRecord.FileFlag := ((fd.FSearchRec.Attr and faDirectory) = 0);  
            FChangeRecord.Directory := FDirectories[R - WAIT_OBJECT_0];  
            Synchronize(Notify);  
          end  
          else begin  
            // file/directory is modified  
            TFileData(FFilesData.Objects[Index]).FFound := True;  
            CompareSearchRec(TFileData(FFilesData.Objects[Index]).FSearchRec, fd.FSearchRec);  
            while (FChangeRecord.ChangeType <> ctNone) do begin  
              FChangeRecord.Name := fd.Name;  
              FChangeRecord.FileFlag := ((fd.FSearchRec.Attr and faDirectory) = 0);  
              FChangeRecord.Directory := FDirectories[R - WAIT_OBJECT_0];  
              Synchronize(Notify);  
              CompareSearchRec(TFileData(FFilesData.Objects[Index]).FSearchRec, fd.FSearchRec);  
            end;  
          end;  
          FTempFilesData.Delete(0);  
        end;  
        for i := FFilesData.Count downto 1 do if not TFileData(FFilesData.Objects[i-1]).FFound then begin  
          // file/directory is deleted  
          fd := TFileData(FFilesData.Objects[i-1]);  
          FChangeRecord.ChangeType := ctRemove;  
          FChangeRecord.Name := fd.Name;  
          FChangeRecord.FileFlag := ((fd.FSearchRec.Attr and faDirectory) = 0);  
          FChangeRecord.Directory := FDirectories[R - WAIT_OBJECT_0];  
          FFilesData.Delete(i-1);  
          Synchronize(Notify);  
        end;  
        FindNextChangeNotification(THandle(FHandles[R - WAIT_OBJECT_0]));  
      end;  
    end;  
  except end;  
end;  
  
  
procedure TReadDirChangesThread.Notify;  
  var cr : TDirectoryChangeRecord;  
begin  
  cr := FChangeRecord;  
  if (cr.ChangeType <> ctNone) then FOwner.DoChangeDirectory(cr);  
end;  
  
constructor TReadDirChangesThread.Create(Owner : TOxygenDirectorySpy);  
begin  
  inherited Create(True);  
  FOwner := Owner;  
  FHandles := TList.Create;  
  pHandles := nil;  
  FDirectories := TStringList.Create;  
  FDirectories.Sorted := True;  
  FDirectories.Duplicates := dupIgnore;  
  FreeOnTerminate := True;  
  FFilesData := TFileDataList.Create;  
  FFilesData.Sorted := True;  
  FFilesData.Duplicates := dupIgnore;  
  FTempFilesData := TFileDataList.Create;  
  FTempFilesData.Sorted := True;  
  FTempFilesData.Duplicates := dupIgnore;  
  //Reset;  
end;  
  
procedure TReadDirChangesThread.ReleaseHandle;  
  var i : Integer;  
begin  
  if (pHandles <> nil) then FreeMem(pHandles,FHandles.Count * SizeOf(THandle));  
  pHandles := nil;  
  for i := 1 to FHandles.Count do if (THandle(FHandles[i-1]) <> INVALID_HANDLE_VALUE) then FindCloseChangeNotification(THandle(FHandles[i-1]));//CloseHandle(FHandle);  
  FHandles.Clear;  
end;  
  
destructor TReadDirChangesThread.Destroy;  
begin  
  ReleaseHandle;  
  FHandles.Free;  
  FDirectories.Free;  
  FFilesData.Clear;  
  FFilesData.Free;  
  FTempFilesData.Clear;  
  FTempFilesData.Free;  
  inherited Destroy;  
end;  
  
procedure TReadDirChangesThread.AllocateHandle;  
  var i : Integer;  
      h : THandle;  
begin  
  if (FOwner <> nil) then for i := 1 to FDirectories.Count do begin  
    h := FindFirstChangeNotification(PChar(FDirectories[i-1]), FOwner.WatchSubTree, FILE_NOTIFY_CHANGE_FILE_NAME +  
                                           FILE_NOTIFY_CHANGE_DIR_NAME + FILE_NOTIFY_CHANGE_ATTRIBUTES +  
                                           FILE_NOTIFY_CHANGE_SIZE + FILE_NOTIFY_CHANGE_LAST_WRITE);  
    {h := FindFirstChangeNotification(PChar(FDirectories[i-1]), FALSE, FILE_NOTIFY_CHANGE_FILE_NAME + 
                                           FILE_NOTIFY_CHANGE_DIR_NAME + FILE_NOTIFY_CHANGE_ATTRIBUTES + 
                                           FILE_NOTIFY_CHANGE_SIZE + FILE_NOTIFY_CHANGE_LAST_WRITE);}  
    if (h <> INVALID_HANDLE_VALUE) then FHandles.Add(Pointer(h)) else raise Exception.Create('Error allocating handle: #'+IntToStr(GetLastError));  
  end;  
  GetMem(pHandles,FHandles.Count * SizeOf(THandle));  
  for i := 1 to FHandles.Count do pHandles^[i-1] := THandle(FHandles[i-1]);  
  ReadDirectories(FFilesData);  
end;  
  
procedure TReadDirChangesThread.ReadDirectories(DestData : TFileDataList);  
  var i : Integer;  
  
  procedure AppendDirContents(const Directory : String);  
    var sr : TSearchRec;  
        s : String;  
  begin  
    if (Directory[Length(Directory)] <> '') then s := Directory + '*.*' else s := Directory + '*.*';  
    if (FindFirst(s,faAnyFile,sr) = 0) then begin  
      if (sr.Name <> '.') and (sr.Name <> '..') then begin  
        DestData.AddSearchRec(Directory,sr);  
        if ((sr.Attr and faDirectory) <> 0) and FOwner.WatchSubTree then AppendDirContents(Directory + '' + sr.Name);  
      end;  
      while (FindNext(sr) = 0) do if (sr.Name <> '.') and (sr.Name <> '..') then begin  
        DestData.AddSearchRec(Directory,sr);  
        if ((sr.Attr and faDirectory) <> 0) and FOwner.WatchSubTree then AppendDirContents(Directory + '' + sr.Name);  
      end;  
      FindClose(sr);  
    end;  
  end;  
  
begin  
  for i := 1 to FDirectories.Count do AppendDirContents(FDirectories[i-1]);  
end;  
  
procedure TReadDirChangesThread.Reset;  
begin  
  ReleaseHandle;  
  if (FDirectories.Count = 0) then Exit;  
  AllocateHandle;  
  if (FHandles.Count > 0) then Resume;  
end;  
  
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
//       TOxygenDirectorySpy  
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////  
constructor TOxygenDirectorySpy.Create(AOwner : TComponent);  
begin  
  inherited Create(AOwner);  
  FEnabled := False;  
  FWatchSubTree := False;  
  FDirectories := TStringList.Create;  
  TStringList(FDirectories).Sorted := True;  
  TStringList(FDirectories).Duplicates := dupIgnore;  
  FOnChangeDirectory := nil;  
  FThread := nil;  
{$IFDEF O2_SW}  
  if (MessageDlg('This version of TOxygenDirectorySpy is NOT REGISTERED. '+#13#10+  
                 'Press Ok to visit http://www.oxygensoftware.com and register.',  
                 mtWarning,[mbOk,mbCancel],0) = mrOk) then ShellExecute(0,'open','http://www.oxygensoftware.com',nil,nil,SW_SHOWNORMAL);  
{$ENDIF}  
end;  
  
procedure TOxygenDirectorySpy.SetEnabled(const Value : Boolean);  
begin  
  if (csDesigning in ComponentState) then Exit;  
  if (Value = FEnabled) then Exit;  
  CheckDirectories;  
  if (FDirectories.Count = 0) then FEnabled := False else FEnabled := Value;  
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then FWatchSubTree := False;  
  if FEnabled then begin  
    FThread := TReadDirChangesThread.Create(Self);  
    FThread.FDirectories.Clear;  
    FThread.FDirectories.AddStrings(FDirectories);  
    FThread.Reset;  
  end  
  else if (FThread <> nil) then begin  
    FThread.Terminate;  
    FThread.WaitFor;  
    //TerminateThread(FThread.Handle,0);  
    FThread := nil;  
  end;  
end;  
  
procedure TOxygenDirectorySpy.CheckDirectories;  
  var i : Integer;  
      s : String;  
begin  
  for i := FDirectories.Count downto 1 do begin  
    s := Trim(FDirectories[i-1]);  
    if (s = '') or (not DirectoryExists(s)) then FDirectories.Delete(i-1);  
  end;  
  while (FDirectories.Count > MAXIMUM_WAIT_OBJECTS) do FDirectories.Delete(FDirectories.Count - 1);  
end;  
  
procedure TOxygenDirectorySpy.SetDirectories(const Value : TStrings);  
begin  
  FDirectories.Clear;  
  FDirectories.AddStrings(Value);  
  CheckDirectories;  
  if FEnabled then begin  
    SetEnabled(False);  
    SetEnabled(True);  
  end;  
end;  
  
procedure TOxygenDirectorySpy.SetWatchSubTree(const Value : Boolean);  
begin  
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then begin  
    FWatchSubTree := False;  
    Exit;  
  end;  
  if (FWatchSubTree = Value) then Exit;  
  FWatchSubTree := Value;  
  if FEnabled then begin  
    SetEnabled(False);  
    SetEnabled(True);  
  end;  
end;  
  
procedure TOxygenDirectorySpy.DoChangeDirectory(ChangeRecord : TDirectoryChangeRecord);  
begin  
  if Assigned(FOnChangeDirectory) then FOnChangeDirectory(Self, ChangeRecord);  
end;  
  
destructor TOxygenDirectorySpy.Destroy;  
begin  
  if (FThread <> nil) then begin  
    FThread.Terminate;  
    FThread.WaitFor;  
    //TerminateThread(FThread.Handle,0);  
    //FThread.Free;  
    FThread := nil;  
  end;  
  inherited Destroy;  
end;  
  
procedure Register;  
begin  
  RegisterComponents('Oxygen', [TOxygenDirectorySpy]);  
end;  
  
  
end.  
 
 
调用单元
[delphi]  
unit utMain;  
  
interface  
  
uses  
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
  Dialogs, StdCtrls, ExtCtrls, O2DirSpy, FileCtrl;  
  
type  
  TMainForm = class(TForm)  
    lstChanges: TListBox;  
    pnl1: TPanel;  
    pnl2: TPanel;  
    pnl3: TPanel;  
    btnAdd: TButton;  
    btnRemove: TButton;  
    pnl4: TPanel;  
    lstDirectoriesListBox: TListBox;  
    pnl5: TPanel;  
    lbl1: TLabel;  
    chkWatchSubTree: TCheckBox;  
    procedure btnAddClick(Sender: TObject);  
    procedure btnRemoveClick(Sender: TObject);  
    procedure FormCreate(Sender: TObject);  
    procedure chkWatchSubTreeClick(Sender: TObject);  
    procedure FormDestroy(Sender: TObject);  
  private  
    OxygenDirectorySpy1: TOxygenDirectorySpy;  
    procedure OxygenDirectorySpy1ChangeDirectory(Sender: TObject;  
      ChangeRecord: TDirectoryChangeRecord);  
    { Private declarations }  
  public  
    { Public declarations }  
  end;  
  
var  
  MainForm: TMainForm;  
  
implementation  
  
{$R *.dfm}  
  
procedure TMainForm.btnAddClick(Sender: TObject);  
  var s : String;  
begin  
  if not SelectDirectory(s, [sdAllowCreate, sdPerformCreate, sdPrompt],0) then Exit;  
  with OxygenDirectorySpy1 do begin  
    Enabled := False;  
    Directories.Add(s);  
    Enabled := True;  
  end;  
  
  with lstDirectoriesListBox do try  
    Items.Clear;  
    Items.AddStrings(OxygenDirectorySpy1.Directories);  
    ItemIndex := 0;  
  except end;  
  btnRemove.Enabled := True;  
  
end;  
  
procedure TMainForm.btnRemoveClick(Sender: TObject);  
var  
  i : Integer;  
begin  
  if (lstDirectoriesListBox.Items.Count = 0) then Exit;  
  i := lstDirectoriesListBox.ItemIndex;  
  if (i = -1) then Exit;  
  lstDirectoriesListBox.Items.Delete(i);  
  with OxygenDirectorySpy1 do begin  
    Enabled := False;  
    Directories.Delete(i);  
    if (Directories.Count > 0) then begin  
      Enabled := True;  
      lstDirectoriesListBox.ItemIndex := 0;  
    end;  
  end;  
  btnRemove.Enabled := (lstDirectoriesListBox.Items.Count > 0);  
end;  
  
procedure TMainForm.chkWatchSubTreeClick(Sender: TObject);  
begin  
  OxygenDirectorySpy1.WatchSubTree := chkWatchSubTree.Checked;  
end;  
  
procedure TMainForm.FormCreate(Sender: TObject);  
begin  
  OxygenDirectorySpy1 := TOxygenDirectorySpy.Create(Self);  
  OxygenDirectorySpy1.OnChangeDirectory := OxygenDirectorySpy1ChangeDirectory;  
  SendMessage(lstChanges.Handle,LB_SETHORIZONTALEXTENT,1000,0);  
end;  
  
procedure TMainForm.FormDestroy(Sender: TObject);  
begin  
  OxygenDirectorySpy1.Free;  
end;  
  
procedure TMainForm.OxygenDirectorySpy1ChangeDirectory(Sender: TObject; ChangeRecord: TDirectoryChangeRecord);  
begin  
  lstChanges.Items.Add(DateTimeToStr(SysUtils.Now) + '  ' + ChangeRecord2String(ChangeRecord));  
  with lstChanges do if (Items.Count > 0) then ItemIndex := Items.Count - 1;  
end;  
  
end.  
 
 
调用窗体
[delphi]  
object MainForm: TMainForm  
  Left = 0  
  Top = 0  
  Caption = 'MainForm'  
  ClientHeight = 388  
  ClientWidth = 485  
  Color = clBtnFace  
  Font.Charset = DEFAULT_CHARSET  
  Font.Color = clWindowText  
  Font.Height = -12  
  Font.Name = 'Tahoma'  
  Font.Style = []  
  OldCreateOrder = False  
  OnCreate = FormCreate  
  OnDestroy = FormDestroy  
  PixelsPerInch = 106  
  TextHeight = 14  
  object lstChanges: TListBox  
    Left = 0  
    Top = 105  
    Width = 485  
    Height = 283  
    Align = alClient  
    ItemHeight = 14  
    TabOrder = 0  
  end  
  object pnl1: TPanel  
    Left = 0  
    Top = 0  
    Width = 485  
    Height = 105  
    Align = alTop  
    TabOrder = 1  
    object pnl2: TPanel  
      Left = 405  
      Top = 1  
      Width = 79  
      Height = 103  
      Align = alRight  
      BevelOuter = bvNone  
      TabOrder = 0  
      object pnl3: TPanel  
        Left = 4  
        Top = 0  
        Width = 75  
        Height = 103  
        Align = alRight  
        BevelOuter = bvNone  
        TabOrder = 0  
        object btnAdd: TButton  
          Left = 4  
          Top = 24  
          Width = 69  
          Height = 21  
          Caption = 'Add'  
          TabOrder = 0  
          OnClick = btnAddClick  
        end  
        object btnRemove: TButton  
          Left = 4  
          Top = 52  
          Width = 69  
          Height = 21  
          Caption = 'Remove'  
          Enabled = False  
          TabOrder = 1  
          OnClick = btnRemoveClick  
        end  
      end  
    end  
    object pnl4: TPanel  
      Left = 1  
      Top = 1  
      Width = 404  
      Height = 103  
      Align = alClient  
      BevelOuter = bvNone  
      TabOrder = 1  
      object lstDirectoriesListBox: TListBox  
        Left = 0  
        Top = 29  
        Width = 404  
        Height = 74  
        Align = alClient  
        ItemHeight = 14  
        TabOrder = 0  
      end  
      object pnl5: TPanel  
        Left = 0  
        Top = 0  
        Width = 404  
        Height = 29  
        Align = alTop  
        BevelOuter = bvNone  
        TabOrder = 1  
        object lbl1: TLabel  
          Left = 5  
          Top = 8  
          Width = 115  
          Height = 14  
          Caption = 'Directories to watch:'  
        end  
        object chkWatchSubTree: TCheckBox  
          Left = 220  
          Top = 4  
          Width = 125  
          Height = 17  www.2cto.com
          Caption = 'Watch subdirectories'  
          Checked = True  
          State = cbChecked  
          TabOrder = 0  
          OnClick = chkWatchSubTreeClick  
        end  
      end  
    end  
  end  
end

View Code

监控文件夹

const
  SHCNE_RENAMEITEM = $1;
  SHCNE_Create = $2;
  SHCNE_Delete = $4;
  SHCNE_MKDIR = $8;
  SHCNE_RMDIR = $10;
  SHCNE_MEDIAInsertED = $20;
  SHCNE_MEDIAREMOVED = $40;
  SHCNE_DRIVEREMOVED = $80;
  SHCNE_DRIVEADD = $100;
  SHCNE_NETSHARE = $200;
  SHCNE_NETUNSHARE = $400;
  SHCNE_ATTRIBUTES = $800;
  SHCNE_UpdateDIR = $1000;
  SHCNE_UpdateITEM = $2000;
  SHCNE_SERVERDISCONNECT = $4000;
  SHCNE_UpdateIMAGE = $8000;
  SHCNE_DRIVEADDGUI = $10000;
  SHCNE_RENAMEFOLDER = $20000;
  SHCNE_FREESPACE = $40000;
  SHCNE_ASSOCCHANGED = $8000000;
  SHCNE_DISKEVENTS = $2381F;
  SHCNE_GLOBALEVENTS = $C0581E0;
  SHCNE_ALLEVENTS = $7FFFFFFF;
  SHCNE_INTERRUPT = $80000000;
  SHCNF_IDLIST = 0;
  // LPITEMIDLIST
  SHCNF_PATHA = $1;
  // path name
  SHCNF_PRINTERA = $2;
  // printer friendly name
  SHCNF_DWORD = $3;
  // DWORD
  SHCNF_PATHW = $5;
  // path name
  SHCNF_PRINTERW = $6;
  // printer friendly name
  SHCNF_TYPE = $FF;
  SHCNF_FLUSH = $1000;
  SHCNF_FLUSHNOWAIT = $2000;
  SHCNF_PATH = SHCNF_PATHW;
  SHCNF_PRINTER = SHCNF_PRINTERW;
  WM_SHNOTIFY = $401;
  NOERROR = 0;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private
    procedure WMShellReg(var Message: TMessage); message WM_SHNOTIFY;
  public
    { Public declarations }
  end;

type
  PSHNOTIFYSTRUCT = ^SHNOTIFYSTRUCT;

  SHNOTIFYSTRUCT = record
    dwItem1: PItemIDList;
    dwItem2: PItemIDList;
  end;

type
  PSHFileInfoByte = ^SHFileInfoByte;

  _SHFileInfoByte = record
    hIcon: Integer;
    iIcon: Integer;
    dwAttributes: Integer;
    szDisplayName: array [0 .. 259] of char;
    szTypeName: array [0 .. 79] of char;
  end;

  SHFileInfoByte = _SHFileInfoByte;

type
  PIDLSTRUCT = ^IDLSTRUCT;

  _IDLSTRUCT = record
    pidl: PItemIDList;
    bWatchSubFolders: Integer;
  end;

  IDLSTRUCT = _IDLSTRUCT;

function SHNotify_Register(hWnd: Integer): Bool;
function SHNotify_UnRegister: Bool;
function SHEventName(strPath1, strPath2: string; lParam: Integer): string;
function SHChangeNotifyDeregister(hNotify: Integer): Integer; stdcall;
external 'Shell32.dll' index 4;
function SHChangeNotifyRegister(hWnd, uFlags, dwEventID, uMSG,
  cItems: LongWord; lpps: PIDLSTRUCT): Integer; stdcall;
external 'Shell32.dll' index 2;
function SHGetFileInfoPidl(pidl: PItemIDList; dwFileAttributes: Integer;
  psfib: PSHFileInfoByte; cbFileInfo: Integer; uFlags: Integer): Integer;
  stdcall; external 'Shell32.dll' name 'SHGetFileInfoA';

var
  Form1: TForm1;
  m_hSHNotify: Integer;
  m_pidlDesktop: PItemIDList;
implementation

{ uses
  Graphics;
}
{$R *.dfm}

function SHEventName(strPath1, strPath2: string; lParam: Integer): string;
var
  sEvent: string;
begin
  case lParam of // 根据参数设置提示消息
    SHCNE_RENAMEITEM:
      sEvent := '重命名文件' + strPath1 + '为' + strPath2;
    SHCNE_Create:
      sEvent := '建立文件 文件名：' + strPath1;
    SHCNE_Delete:
      sEvent := '删除文件 文件名：' + strPath1;
    SHCNE_MKDIR:
      sEvent := '新建目录 目录名：' + strPath1;
    SHCNE_RMDIR:
      sEvent := '删除目录 目录名：' + strPath1;
    SHCNE_MEDIAInsertED:
      sEvent := strPath1 + '中插入可移动存储介质';
    SHCNE_MEDIAREMOVED:
      sEvent := strPath1 + '中移去可移动存储介质' + strPath1 + ' ' + strPath2;
    SHCNE_DRIVEREMOVED:
      sEvent := '移去驱动器' + strPath1;
    SHCNE_DRIVEADD:
      sEvent := '添加驱动器' + strPath1;
    SHCNE_NETSHARE:
      sEvent := '改变目录' + strPath1 + '的共享属性';
    SHCNE_ATTRIBUTES:
      sEvent := '改变文件目录属性 文件名' + strPath1;
    SHCNE_UpdateDIR:
      sEvent := '更新目录' + strPath1;
    SHCNE_UpdateITEM:
      sEvent := '更新文件 文件名：' + strPath1;
    SHCNE_SERVERDISCONNECT:
      sEvent := '断开与服务器的连接' + strPath1 + ' ' + strPath2;
    SHCNE_UpdateIMAGE:
      sEvent := 'SHCNE_UpdateIMAGE';
    SHCNE_DRIVEADDGUI:
      sEvent := 'SHCNE_DRIVEADDGUI';
    SHCNE_RENAMEFOLDER:
      sEvent := '重命名文件夹' + strPath1 + '为' + strPath2;
    SHCNE_FREESPACE:
      sEvent := '磁盘空间大小改变';
    SHCNE_ASSOCCHANGED:
      sEvent := '改变文件关联';
  else
    sEvent := '未知操作' + IntToStr(lParam);
  end;
  Result := sEvent;
end;

function SHNotify_Register(hWnd: Integer): Bool;
var
  ps: IDLSTRUCT;
begin
{$R-}
  Result := False;
  if m_hSHNotify = 0 then
  begin
    // 获取桌面文件夹的Pidl
    if SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, m_pidlDesktop)
      <> NOERROR then
    begin
      Form1.close;
    end;
    if Boolean(m_pidlDesktop) then
    begin
      ps.bWatchSubFolders := 1;
      ps.pidl := m_pidlDesktop;
      // 利用SHChangeNotifyRegister函数注册系统消息处理
      m_hSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE or SHCNF_IDLIST),
        (SHCNE_ALLEVENTS or SHCNE_INTERRUPT), WM_SHNOTIFY, 1, @ps);
      Result := Boolean(m_hSHNotify); // mmmmmmmm
    end
    else
      // 如果出现错误就使用 CoTaskMemFree函数来释放句柄
      CoTaskMemFree(m_pidlDesktop);
  end;
{$R+ }
end;

function SHNotify_UnRegister: Bool;
begin
  Result := False;
  if Boolean(m_hSHNotify) then
  begin
    // 取消系统消息监视，同时释放桌面的Pidl
    if Boolean(SHChangeNotifyDeregister(m_hSHNotify)) then
    begin
{$R-}
      m_hSHNotify := 0;
      CoTaskMemFree(m_pidlDesktop);
      Result := True;
{$R-}
    end;
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  m_hSHNotify := 0;
  if SHNotify_Register(self.Handle) then
  begin // 注册Shell监视
    ShowMessage('Shell监视程序成功注册');
    Button1.Enabled := False;
  end
  else
    ShowMessage('Shell监视程序注册失败');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Boolean(m_pidlDesktop) then
    SHNotify_UnRegister;
end;

procedure TForm1.WMShellReg(var Message: TMessage);
var
  strPath1, strPath2: string;
  charPath: array [0 .. 259] of char;
  pidlItem: PSHNOTIFYSTRUCT;
begin
  pidlItem := PSHNOTIFYSTRUCT(Message.wParam);
  // 获得系统消息相关得路径
  SHGetPathFromIDList(pidlItem.dwItem1, charPath);
  strPath1 := charPath;
  SHGetPathFromIDList(pidlItem.dwItem2, charPath);
  strPath2 := charPath;
  Memo1.Lines.Add(SHEventName(strPath1, strPath2, Message.lParam) + chr(13)
      + chr(10));
end;

end.

View Code

文件监控

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, shlobj, Activex;

const
  WM_SHNOTIFY = $401;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    MM: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private { Private declarations }
    procedure WMShellReg(var Message: TMessage); message WM_SHNOTIFY;
  public { Public declarations }
  end;

type
  PIDLSTRUCT = ^IDLSTRUCT;

  _IDLSTRUCT = record
    pidl: PItemIDList;
    bWatchSubFolders: Integer;
  end;

  IDLSTRUCT = _IDLSTRUCT;

type
  PSHNOTIFYSTRUCT = ^SHNOTIFYSTRUCT;

  SHNOTIFYSTRUCT = record
    dwItem1: PItemIDList;
    dwItem2: PItemIDList;
  end;

  // 注册通知消息
function RegSHNotify(hWnd: Integer): Bool;
// 解除通知注册
function UnregSHNotify: Bool;
// 获取消息具体内容
function NotifyReceipt(wParam: wParam; lParam: lParam): string;
// 定义未公开API函数
Function SHChangeNotifyDeregister(hNotify: Integer): Integer; stdcall;
external ' Shell32.dll ' index 4;
Function SHChangeNotifyRegister(hWnd, uFlags, dwEventID, uMSG,
  cItems: LongWord; lpps: PIDLSTRUCT): Integer; stdcall;
external ' Shell32.dll ' index 2;

var
  Form1: TForm1;
  g_HSHNotify: Integer;
  g_pidlDesktop: PItemIDList;

implementation

{$R *.dfm}

// 获取消息具体内容
function NotifyReceipt(wParam: wParam; lParam: lParam): string;
var
  strEvent: String;
  strPath1, strPath2: String;
  szBuf: array [0 .. MAX_PATH] of char;
  pidlItem: PSHNOTIFYSTRUCT;
begin
  pidlItem := PSHNOTIFYSTRUCT(wParam);
  // 获得系统消息相关的路径
  SHGetPathFromIDList(pidlItem.dwItem1, szBuf);
  strPath1 := szBuf;
  SHGetPathFromIDList(pidlItem.dwItem2, szBuf);
  strPath2 := szBuf;
  // 根据参数设置提示消息
  case lParam of
    SHCNE_RENAMEITEM:
      strEvent := ' 重命名文件: ' + strPath1 + ' 为 ' + strPath2;
    SHCNE_CREATE:
      strEvent := ' 建立文件, 文件名: ' + strPath1;
    SHCNE_DELETE:
      strEvent := ' 删除文件, 文件名 ： ' + strPath1;
    SHCNE_MKDIR:
      strEvent := ' 新建目录, 目录名 ： ' + strPath1;
    SHCNE_RMDIR:
      strEvent := ' 删除目录, 目录名 ： ' + strPath1;
    SHCNE_ATTRIBUTES:
      strEvent := ' 改变文件目录属性, 文件名 ： ' + strPath1;
    SHCNE_MEDIAINSERTED:
      strEvent := strPath1 + ' 中插入可移动存储介质 ';
    SHCNE_MEDIAREMOVED:
      strEvent := strPath1 + ' 中移去可移动存储介质 ';
    SHCNE_DRIVEREMOVED:
      strEvent := ' 移去驱动器: ' + strPath1;
    SHCNE_DRIVEADD:
      strEvent := ' 添加驱动器: ' + strPath1;
    SHCNE_NETSHARE:
      strEvent := ' 改变目录 ' + strPath1 + ' 的共享属性 ';
    SHCNE_UPDATEDIR:
      strEvent := ' 更新目录: ' + strPath1;
    SHCNE_UPDATEITEM:
      strEvent := ' 更新文件, 文件名: ' + strPath1;
    SHCNE_SERVERDISCONNECT:
      strEvent := ' 断开与服务器的连接: ' + strPath1 + ' ' + strPath2;
    SHCNE_UPDATEIMAGE:
      strEvent := ' 更新图标: ' + strPath1 + ' ' + strPath2;
    SHCNE_DRIVEADDGUI:
      strEvent := ' 添加并显示驱动器: ' + strPath1;
    SHCNE_RENAMEFOLDER:
      strEvent := ' 重命名文件夹: ' + strPath1 + ' 为 ' + strPath2;
    SHCNE_FREESPACE:
      strEvent := ' 磁盘空间大小改变: ' + strPath1 + ' ' + strPath2;
    SHCNE_ASSOCCHANGED:
      strEvent := ' 改变文件关联 ' + strPath1 + ' ' + strPath2;
  else
    strEvent := ' 其他操作 ' + IntToStr(lParam);
  end;
  Result := strEvent;
end;

// 注册通知消息
function RegSHNotify(hWnd: Integer): Bool;
var
  ps: PIDLSTRUCT;
begin
  Result := False;
  If g_HSHNotify = 0 then
  begin
    // 取得桌面的IDL
    SHGetSpecialFolderLocation(0, CSIDL_DESKTOP
      { CSIDL_DRIVES } , g_pidlDesktop);
    // if SHGetSpecialFolderLocation(0, CSIDL_DESKTOP,g_pidlDesktop)<> NOERROR then
    // Form1.close;
    if Boolean(g_pidlDesktop) then
    begin
      getmem(ps, sizeof(IDLSTRUCT));
      ps.bWatchSubFolders := 1;
      ps.pidl := g_pidlDesktop;
      // 注册Windows监视
      g_HSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),
        (SHCNE_ALLEVENTS Or SHCNE_INTERRUPT), WM_SHNOTIFY, 1, ps);
      Result := Boolean(g_HSHNotify);
    end
    else
      // 如果出现错误就使用 CoTaskMemFree函数来释放句柄
      CoTaskMemFree(g_pidlDesktop);
  end;
end;
// 解除通知注册
function UnregSHNotify: Bool;
begin
  Result := False;
  if Boolean(g_HSHNotify) Then
  begin
    // 取消系统消息监视，同时释放桌面的IDL
    if Boolean(SHChangeNotifyDeregister(g_HSHNotify)) Then
    begin
      g_HSHNotify := 1;
      CoTaskMemFree(g_pidlDesktop);
      // Boolean(g_pidlDesktop) :=0;
      Result := True;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  g_HSHNotify := 0;
  MM.Lines.Clear;
  if RegSHNotify(Handle) then
  begin
    MM.Lines.Add('开始监视程序-->成功!');
    Button1.Enabled := False;
  end
  else
    MM.Lines.Add('开始监视程序-->失败!');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if Boolean(g_pidlDesktop) then
  begin
    if UnregSHNotify then
    begin
      MM.Lines.Add('停止监视程序-->成功!');
      Button1.Enabled := True;
    end
    else
      MM.Lines.Add('停止监视程序-->失败!');
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  MessageBox(0, '文件监视功能演示' + #13#10 + 'Coded By: hnxyy' + #13#10 +
      'Homepage: http://www.wrsky.com' + #13#10 + 'Contact: QQ:19026695',
    '火狐出品', 0);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // 在程序退出的同时删除监视
  if Boolean(g_pidlDesktop) then
    UnregSHNotify;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption := Application.Title;
end;

procedure TForm1.WMShellReg(var Message: TMessage);
begin
  MM.Lines.Add(NotifyReceipt(Message.wParam, Message.lParam));
  // +chr(13)+chr(10));
end;

end.

View Code