Skip to content

Instantly share code, notes, and snippets.

@jymcheong
Last active January 6, 2022 01:22
Show Gist options
  • Save jymcheong/27b752756174ceb6990bac51dcbb5eee to your computer and use it in GitHub Desktop.
Save jymcheong/27b752756174ceb6990bac51dcbb5eee to your computer and use it in GitHub Desktop.
Monitor changes to a directory. New project > drag a TMemo & TDirectoryEdit to the form > link the respect event procedure to the controls under Event tab...
// source: https://forum.lazarus.freepascal.org/index.php/topic,46255.msg334820.html#msg334820
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, EditBtn, StdCtrls,
jwaWinBase, InterfaceBase;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
DirectoryEdit1: TDirectoryEdit;
Memo1: TMemo;
procedure DirectoryEdit1EditingDone(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FNewChangeEvent: THandle;
FDirectory: THandle;
FChangesHandler: PEventHandler;
FBuffer: Pointer;
FOverlap: TOverlapped;
procedure CancelWait;
procedure NewDirChanges(AData: PtrInt; AFlags: DWORD);
procedure WaitNextChanges;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses jwaWinNT;
const
CBufLength = 64 * 1024; // For network dir cannot exceed 64K
procedure TForm1.CancelWait;
begin
if FDirectory <> 0 then
begin
CancelIO(FDirectory);
FDirectory := 0;
end;
Caption := 'No watch';
end;
procedure TForm1.WaitNextChanges;
const
CNotifyFlags = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME;
begin
ZeroMemory(@FOverlap, SizeOf(FOverlap));
FOverlap.hEvent := FNewChangeEvent;
if ReadDirectoryChangesW(FDirectory, FBuffer, CBufLength, True, CNotifyFlags, nil, @FOverlap, nil) then
Caption := 'Wathing ' + DirectoryEdit1.Directory
else
CancelWait;
end;
procedure TForm1.DirectoryEdit1EditingDone(Sender: TObject);
const
CShareFlags = FILE_SHARE_READ or FILE_SHARE_WRITE {or FILE_SHARE_DELETE};
COpenFlags = FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OVERLAPPED;
begin
if not Assigned(FChangesHandler) then
Exit;
CancelWait;
if not DirectoryExists(DirectoryEdit1.Directory) then
Exit;
FDirectory := CreateFileW(PWideChar(UTF8Decode(DirectoryEdit1.Directory)),
GENERIC_READ, CShareFlags, nil, OPEN_EXISTING, COpenFlags, 0);
if FDirectory <> INVALID_HANDLE_VALUE then
WaitNextChanges;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FNewChangeEvent := CreateEvent(nil, False, False, nil);
if FNewChangeEvent = 0 then
Exit;
FChangesHandler := WidgetSet.AddEventHandler(FNewChangeEvent, 0, @NewDirChanges, 0);
if Assigned(FChangesHandler) then
FBuffer := GetMem(CBufLength);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(FChangesHandler) then
begin
WidgetSet.RemoveEventHandler(FChangesHandler);
CancelWait;
FreeMem(FBuffer);
CloseHandle(FNewChangeEvent);
end;
end;
procedure TForm1.NewDirChanges(AData: PtrInt; AFlags: DWORD);
var
PBuf: PByte;
PInfo: PFileNotifyInformation;
FileName: UnicodeString;
begin
if FOverlap.InternalHigh = 0 then
begin
CancelWait;
Exit;
end;
PBuf := FBuffer;
repeat
PInfo := Pointer(PBuf);
Inc(PBuf, PInfo^.NextEntryOffset);
SetString(FileName, PInfo^.FileName, PInfo^.FileNameLength div SizeOf(WideChar));
case PInfo^.Action of
FILE_ACTION_ADDED:
Memo1.Append(Format('Item "%s" added', [FileName]));
FILE_ACTION_REMOVED:
Memo1.Append(Format('Item "%s" removed', [FileName]));
FILE_ACTION_RENAMED_OLD_NAME:
Memo1.Append(Format('Item "%s" renaming...', [FileName]));
FILE_ACTION_RENAMED_NEW_NAME:
Memo1.Append(Format('new name is "%s"', [FileName]));
else
// Other ignore
end;
until PInfo^.NextEntryOffset = 0;
WaitNextChanges;
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment