Delphi目录监控、目录监听

资料地址：

1.https://www.cnblogs.com/studypanp/p/4890970.html

单元代码：

 (******************************************
   文件和目录监控
   当磁盘上有文件或目录操作时，产生事件
   使用方法：

   开始监控: 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;
 原始资料：https://www.cnblogs.com/studypanp/p/4890970.html
 环境情况：win7  + DelphiXE10.
 更新情况：修改20190315 增加多目录处理
 ******************************************)
 unit ZJQPathWatch;

 interface

 uses
   Winapi.Messages, System.SysUtils, FMX.Types, FMX.Platform.Win, WinAPI.ShlObj,
   Winapi.ActiveX, WinApi.Windows, VCL.Dialogs,
   System.Classes;//TStringList

 const
   WM_SHNOTIFY = $;

 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 ;
   Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;lpps:PIDLSTRUCT):integer;stdcall; external 'Shell32.dll' index ;

   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;
   g_WatchPathList: TStringList;

 implementation

 function GetPathIsExist(AWatchPathList: TStringList; APath: string): Boolean;
 var
   I: Integer;
 begin
   Result := False;
   for I :=  to AWatchPathList.Count - do
   begin
     if APath.ToUpper.StartsWith(AWatchPathList[I]) then
     begin
       Result := True;
       Break;
     end;
   end;
 end;

 function PathWatch(hWND: Integer; Path: String = ''): Boolean;
 var
   ps:PIDLSTRUCT;
 begin
   result := False;
   Path := Path.Replace('/','\');
   if(hWnd >= ) then begin  //  开始监控
 //    g_WatchPath := Path.ToUpper;
     g_WatchPathList.Add(Path.ToUpper);

     if g_HSHNotify =  then begin
       SHGetSpecialFolderLocation(, CSIDL_DESKTOP, g_pidlDesktop);
       if Boolean(g_pidlDesktop) then
       begin
         getmem(ps, sizeof(IDLSTRUCT));
         ps.bWatchSubFolders := ;
         ps.pidl := g_pidlDesktop;
         g_HSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT),WM_SHNOTIFY, , 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 := ;
       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[..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 (GetPathIsExist(g_WatchPathList, s1))) and (not s1.Contains('_plate')) then
   begin
     callback(a,s1,g_WatchPath);
   end;
 end;

 initialization
 g_WatchPathList := TStringList.Create;
 finalization
 FreeAndNil(g_WatchPathList);

 end.

调用代码：

 unit Unit1;

 interface

 uses
   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
   ZJQPathWatch,//引入
   System.DateUtils;//引入

 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     Edit1: TEdit;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     procedure MsgListern(var Msg: TMessage); message WM_SHNOTIFY;// 触发监听事件
     { Private declarations }
   public
     { Public declarations }
   end;

 var
   Form1: TForm1;
   PrePostTime: TDateTime; //定义原始时间
 implementation

 {$R *.dfm}

 { TForm1 }

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   PathWatch(self.Handle, 'e:\ABC');
   PathWatch(self.Handle, 'E:\abd');

 //  PathWatch(self.Handle, '\\gccp-builder8\builder_release');
 end;

 procedure TForm1.Button2Click(Sender: TObject);
 begin
   PathWatch(-);
 end;

 procedure TForm1.FormCreate(Sender: TObject);
 begin
   PrePostTime := Now;
 end;

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

 end.