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 64 + DelphiXE10.2
更新情况：修改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 = $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;
  g_WatchPathList: TStringList;

implementation

function GetPathIsExist(AWatchPathList: TStringList; APath: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to AWatchPathList.Count -1 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 >= 0) then begin  //  开始监控
//    g_WatchPath := Path.ToUpper;
    g_WatchPathList.Add(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 (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-builder8uilder_release');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PathWatch(-1);
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) >= 5 then //两个时间之间相差的秒数
      begin
       // 这里处理监控到后   要响应的事情
        I := I + 1;
      end;
    end;
    if(act='新建目录') then
    begin
      if SecondsBetween(Now, PrePostTime) >= 5 then //两个时间之间相差的秒数
      begin
       // 这里处理监控到后   要响应的事情
        I := I + 1;
      end;
    end;
  end);
end;

end.