1 (******************************************
  2   文件和目录监控
  3   当磁盘上有文件或目录操作时，产生事件
  4   使用方法：
  5 
  6   开始监控: PathWatch(Self.Handle, 'C:\FtpFolder');
  7   解除监控：PathWatch(-1);
  8 
  9   在窗体中加消息监听
 10   private
 11     { Private declarations }
 12     procedure MsgListern(var Msg:TMessage);message WM_SHNOTIFY;
 13 
 14   实现：
 15   procedure TForm1.MsgListern(var Msg:TMessage);
 16   begin
 17     PathWatch(Msg,procedure(a,s1,s2:String) begin
 18       Log('文件事件是：'  +a);
 19       Log('文件名称是：'  +s1);
 20       Log('另外的参数是：'+s2);
 21     end);
 22   end;
 23 原始资料：https://www.cnblogs.com/studypanp/p/4890970.html
 24 环境情况：win7 64 + DelphiXE10.2
 25 更新情况：修改20190315 增加多目录处理
 26 ******************************************)
 27 unit ZJQPathWatch;
 28 
 29 interface
 30 
 31 uses
 32   Winapi.Messages, System.SysUtils, FMX.Types, FMX.Platform.Win, WinAPI.ShlObj,
 33   Winapi.ActiveX, WinApi.Windows, VCL.Dialogs,
 34   System.Classes;//TStringList
 35 
 36 const
 37   WM_SHNOTIFY = $401;
 38 
 39 type
 40   PIDLSTRUCT = ^IDLSTRUCT;
 41     _IDLSTRUCT = record
 42     pidl : PItemIDList;
 43     bWatchSubFolders : Integer;
 44   end;
 45   IDLSTRUCT =_IDLSTRUCT;
 46 
 47 type
 48   PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT;
 49     SHNOTIFYSTRUCT = record
 50     dwItem1 : PItemIDList;
 51     dwItem2 : PItemIDList;
 52   end;
 53 
 54   Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall; external 'Shell32.dll' index 4;
 55   Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;lpps:PIDLSTRUCT):integer;stdcall; external 'Shell32.dll' index 2;
 56 
 57   function PathWatch(hWND: Integer; Path:String = ''):Boolean; overload;
 58   function PathWatch(hWND: TWindowHandle; Path:String = ''):Boolean; overload;
 59   function PathWatch(var Msg: TMessage; callback: TProc<String, String, String>): Boolean; overload;
 60 
 61 var
 62   g_HSHNotify: Integer;
 63   g_pidlDesktop: PItemIDList;
 64   g_WatchPath: String;
 65   g_WatchPathList: TStringList;
 66 
 67 implementation
 68 
 69 function GetPathIsExist(AWatchPathList: TStringList; APath: string): Boolean;
 70 var
 71   I: Integer;
 72 begin
 73   Result := False;
 74   for I := 0 to AWatchPathList.Count -1 do
 75   begin
 76     if APath.ToUpper.StartsWith(AWatchPathList[I]) then
 77     begin
 78       Result := True;
 79       Break;
 80     end;
 81   end;
 82 end;
 83 
 84 function PathWatch(hWND: Integer; Path: String = ''): Boolean;
 85 var
 86   ps:PIDLSTRUCT;
 87 begin
 88   result := False;
 89   Path := Path.Replace('/','\');
 90   if(hWnd >= 0) then begin  //  开始监控
 91 //    g_WatchPath := Path.ToUpper;
 92     g_WatchPathList.Add(Path.ToUpper);
 93 
 94     if g_HSHNotify = 0 then begin
 95       SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, g_pidlDesktop);
 96       if Boolean(g_pidlDesktop) then
 97       begin
 98         getmem(ps, sizeof(IDLSTRUCT));
 99         ps.bWatchSubFolders := 1;
100         ps.pidl := g_pidlDesktop;
101         g_HSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT),WM_SHNOTIFY, 1, ps);
102         Result := Boolean(g_HSHNotify);
103       end
104       else
105         CoTaskMemFree(g_pidlDesktop);
106     end;
107   end
108   else
109   begin  //  解除监控
110     if boolean(g_HSHNotify) then if Boolean(SHChangeNotifyDeregister(g_HSHNotify)) then begin
111       g_HSHNotify := 1;
112       CoTaskMemFree(g_pidlDesktop);
113       result := True;
114     end;
115   end;
116 end;
117 
118 function PathWatch(hWND: TWindowHandle; Path:String=''):Boolean;
119 begin
120   PathWatch(FmxHandleToHWND(hWND),Path);  //  FireMonkey的窗体不接受处理Windows消息
121 end;
122 
123 function PathWatch(var Msg: TMessage; callback:TProc<String, String, String>): Boolean;
124 var
125   a, s1, s2: String;
126   buf: array[0..MAX_PATH] of char;
127   pidlItem: PSHNOTIFYSTRUCT;
128 begin
129   pidlItem := PSHNOTIFYSTRUCT(Msg.WParam);
130   SHGetPathFromIDList(pidlItem.dwItem1, buf); s1 := buf;
131   SHGetPathFromIDList(pidlItem.dwItem2, buf); s2 := buf;
132   a:='';
133   case Msg.LParam of
134 //    SHCNE_RENAMEITEM      : a := '重命名'       ;
135     SHCNE_CREATE          : a := '建立文件'     ;
136 //    SHCNE_DELETE          : a := '删除文件'     ;
137     SHCNE_MKDIR           : a := '新建目录'     ;
138 //    SHCNE_RMDIR           : a := '删除目录'     ;
139 //    SHCNE_ATTRIBUTES      : a := '改变属性'     ;
140 //    SHCNE_MEDIAINSERTED   : a := '插入介质'     ;
141 //    SHCNE_MEDIAREMOVED    : a := '移去介质'     ;
142 //    SHCNE_DRIVEREMOVED    : a := '移去驱动器'   ;
143 //    SHCNE_DRIVEADD        : a := '添加驱动器'   ;
144 //    SHCNE_NETSHARE        : a := '改变共享'     ;
145 //    SHCNE_UPDATEDIR       : a := '更新目录'     ;
146 //    SHCNE_UPDATEITEM      : a := '更新文件'     ;
147 //    SHCNE_SERVERDISCONNECT: a := '断开连接'     ;
148 //    SHCNE_UPDATEIMAGE     : a := '更新图标'     ;
149 //    SHCNE_DRIVEADDGUI     : a := '添加驱动器'   ;
150 //    SHCNE_RENAMEFOLDER    : a := '重命名文件夹' ;
151 //    SHCNE_FREESPACE       : a := '磁盘空间改变' ;
152 //    SHCNE_ASSOCCHANGED    : a := '改变文件关联' ;
153 //  else                      a := '其他操作'     ;
154 
155   end;
156   result := True;
157 
158   if( (a<>'') and (Assigned(callback)) and (GetPathIsExist(g_WatchPathList, s1))) and (not s1.Contains('_plate')) then
159   begin
160     callback(a,s1,g_WatchPath);
161   end;
162 end;
163 
164 initialization
165 g_WatchPathList := TStringList.Create;
166 finalization
167 FreeAndNil(g_WatchPathList);
168 
169 end.

 1 unit Unit1;
 2 
 3 interface
 4 
 5 uses
 6   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
 7   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
 8   ZJQPathWatch,//引入
 9   System.DateUtils;//引入
10 
11 type
12   TForm1 = class(TForm)
13     Button1: TButton;
14     Button2: TButton;
15     Edit1: TEdit;
16     procedure Button1Click(Sender: TObject);
17     procedure FormCreate(Sender: TObject);
18     procedure Button2Click(Sender: TObject);
19   private
20     procedure MsgListern(var Msg: TMessage); message WM_SHNOTIFY;// 触发监听事件
21     { Private declarations }
22   public
23     { Public declarations }
24   end;
25 
26 var
27   Form1: TForm1;
28   PrePostTime: TDateTime; //定义原始时间
29 implementation
30 
31 {$R *.dfm}
32 
33 { TForm1 }
34 
35 procedure TForm1.Button1Click(Sender: TObject);
36 begin
37   PathWatch(self.Handle, 'e:\ABC');
38   PathWatch(self.Handle, 'E:\abd');
39 
40 //  PathWatch(self.Handle, '\\gccp-builder8\builder_release');
41 end;
42 
43 procedure TForm1.Button2Click(Sender: TObject);
44 begin
45   PathWatch(-1);
46 end;
47 
48 procedure TForm1.FormCreate(Sender: TObject);
49 begin
50   PrePostTime := Now;
51 end;
52 
53 procedure TForm1.MsgListern(var Msg: TMessage);
54 var
55   I: Integer;
56 begin
57   PathWatch(Msg, Procedure(act, fn, s2: string) begin
58     if(act='建立文件') then
59     begin
60       if SecondsBetween(Now, PrePostTime) >= 5 then //两个时间之间相差的秒数
61       begin
62        // 这里处理监控到后   要响应的事情
63         I := I + 1;
64       end;
65     end;
66     if(act='新建目录') then
67     begin
68       if SecondsBetween(Now, PrePostTime) >= 5 then //两个时间之间相差的秒数
69       begin
70        // 这里处理监控到后   要响应的事情
71         I := I + 1;
72       end;
73     end;
74   end);
75 end;
76 
77 end.