unit SHChangeNotify;
{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
{$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{$IFNDEF Delphi3orHigher}
OLE2,
{$ELSE}
ActiveX, ComObj,
{$ENDIF}
ShlObj;
const
SHCNF_ACCEPT_INTERRUPTS = $0001;
SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
SHCNF_NO_PROXY = $8000;
type NOTIFYREGISTER = record
pidlPath : PItemIDList;
bWatchSubtree : boolean;
end;
type PNOTIFYREGISTER = ^NOTIFYREGISTER;
type TTextCase = (tcAsIs,tcUppercase,tcLowercase);
type
TOneParmEvent = procedure(Sender : TObject; Flags : cardinal; Path1 : string) of object;
TTwoParmEvent = procedure(Sender : TObject; Flags : cardinal; Path1, Path2 : string) of object;
TEndSessionQueryEvent = procedure(Sender: TObject; var CanEndSession: Boolean) of object;
function SHChangeNotifyRegister(
hWnd : HWND;
dwFlags : integer;
wEventMask : cardinal;
uMsg : UINT;
cItems : integer;
lpItems : PNOTIFYREGISTER) : HWND; stdcall;
function SHChangeNotifyDeregister(
hWnd : HWND) : boolean; stdcall;
function SHILCreateFromPath(Path: Pointer;
PIDL: PItemIDList; var Attributes: ULONG):
HResult; stdcall;
type
TSHChangeNotify = class(TComponent)
private
fTextCase : TTextCase;
fHardDriveOnly : boolean;
NotifyCount : integer;
NotifyHandle : hwnd;
NotifyArray : array[1..26] of NOTIFYREGISTER;
AllocInterface : IMalloc;
PrevMsg : integer;
prevpath1 : string;
prevpath2 : string;
fMessageNo : integer;
fAssocChanged : TTwoParmEvent;
fAttributes : TOneParmEvent;
fCreate : TOneParmEvent;
fDelete : TOneParmEvent;
fDriveAdd : TOneParmEvent;
fDriveAddGUI : TOneParmEvent;
fDriveRemoved : TOneParmEvent;
fMediaInserted : TOneParmEvent;
fMediaRemoved : TOneParmEvent;
fMkDir : TOneParmEvent;
fNetShare : TOneParmEvent;
fNetUnshare : TOneParmEvent;
fRenameFolder : TTwoParmEvent;
fRenameItem : TTwoParmEvent;
fRmDir : TOneParmEvent;
fServerDisconnect : TOneParmEvent;
fUpdateDir : TOneParmEvent;
fUpdateImage : TOneParmEvent;
fUpdateItem : TOneParmEvent;
fEndSessionQuery : TEndSessionQueryEvent;
OwnerWindowProc : TWndMethod;
procedure SetMessageNo(value : integer);
procedure WndProc(var msg: TMessage);
protected
procedure QueryEndSession(var msg: TMessage);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Execute;
procedure Stop;
published
property MessageNo : integer read fMessageNo write SetMessageNo default WM_USER;
property TextCase : TTextCase read fTextCase write fTextCase default tcAsIs;
property HardDriveOnly : boolean read fHardDriveOnly write fHardDriveOnly default True;
property OnAssocChanged : TTwoParmEvent read fAssocChanged write fAssocChanged;
property OnAttributes : TOneParmEvent read fAttributes write fAttributes;
property OnCreate : TOneParmEvent read fCreate write fCreate;
property OnDelete : TOneParmEvent read fDelete write fDelete;
property OnDriveAdd : TOneParmEvent read fDriveAdd write fDriveAdd;
property OnDriveAddGUI : TOneParmEvent read fDriveAddGUI write fDriveAddGUI;
property OnDriveRemoved : TOneParmEvent read fDriveRemoved write fDriveRemoved;
property OnMediaInserted : TOneParmEvent read fMediaInserted write fMediaInserted;
property OnMediaRemoved : TOneParmEvent read fMediaRemoved write fMediaRemoved;
property OnMkDir : TOneParmEvent read fMkDir write fMkDir;
property OnNetShare : TOneParmEvent read fNetShare write fNetShare;
property OnNetUnshare : TOneParmEvent read fNetUnshare write fNetUnshare;
property OnRenameFolder : TTwoParmEvent read fRenameFolder write fRenameFolder;
property OnRenameItem : TTwoParmEvent read fRenameItem write fRenameItem;
property OnRmDir : TOneParmEvent read fRmDir write fRmDir;
property OnServerDisconnect : TOneParmEvent read fServerDisconnect write fServerDisconnect;
property OnUpdateDir : TOneParmEvent read fUpdateDir write fUpdateDir;
property OnUpdateImage : TOneParmEvent read fUpdateImage write fUpdateImage;
property OnUpdateItem : TOneParmEvent read fUpdateItem write fUpdateItem;
property OnEndSessionQuery : TEndSessionQueryEvent
read fEndSessionQuery write fEndSessionQuery;
end;
procedure Register;
implementation
const Shell32DLL = 'shell32.dll';
function SHChangeNotifyRegister;
external Shell32DLL index 2;
function SHChangeNotifyDeregister;
external Shell32DLL index 4;
function SHILCreateFromPath;
external Shell32DLL index 28;
procedure Register;
begin
RegisterComponents('Custom', [TSHChangeNotify]);
end;
constructor TSHChangeNotify.Create (AOwner : TComponent);
begin
inherited Create(AOwner);
fTextCase := tcAsIs;
fHardDriveOnly := true;
fAssocChanged := nil;
fAttributes := nil;
fCreate := nil;
fDelete := nil;
fDriveAdd := nil;
fDriveAddGUI := nil;
fDriveRemoved := nil;
fMediaInserted := nil;
fMediaRemoved := nil;
fMkDir := nil;
fNetShare := nil;
fNetUnshare := nil;
fRenameFolder := nil;
fRenameItem := nil;
fRmDir := nil;
fServerDisconnect := nil;
fUpdateDir := nil;
fUpdateImage := nil;
fUpdateItem := nil;
fEndSessionQuery := nil;
MessageNo := WM_USER;
if csDesigning in ComponentState
then exit;
OwnerWindowProc := (Owner as TWinControl).WindowProc;
(Owner as TWinControl).WindowProc := WndProc;
SHGetMalloc(AllocInterface);
end;
procedure TSHChangeNotify.SetMessageNo(value : integer);
begin
if (value >= WM_USER)
then fMessageNo := value
else raise Exception.Create
('MessageNo must be greater than or equal to '
+ inttostr(WM_USER));
end;
procedure TSHChangeNotify.Execute;
var
EventMask : integer;
driveletter : string;
i : integer;
pidl : PItemIDList;
Attributes : ULONG;
NotifyPtr : PNOTIFYREGISTER;
begin
NotifyCount := 0;
if csDesigning in ComponentState
then exit;
Stop; EventMask := 0;
if assigned(fAssocChanged ) then EventMask := (EventMask or SHCNE_ASSOCCHANGED);
if assigned(fAttributes ) then EventMask := (EventMask or SHCNE_ATTRIBUTES);
if assigned(fCreate ) then EventMask := (EventMask or SHCNE_CREATE);
if assigned(fDelete ) then EventMask := (EventMask or SHCNE_DELETE);
if assigned(fDriveAdd ) then EventMask := (EventMask or SHCNE_DRIVEADD);
if assigned(fDriveAddGUI ) then EventMask := (EventMask or SHCNE_DRIVEADDGUI);
if assigned(fDriveRemoved ) then EventMask := (EventMask or SHCNE_DRIVEREMOVED);
if assigned(fMediaInserted ) then EventMask := (EventMask or SHCNE_MEDIAINSERTED);
if assigned(fMediaRemoved ) then EventMask := (EventMask or SHCNE_MEDIAREMOVED);
if assigned(fMkDir ) then EventMask := (EventMask or SHCNE_MKDIR);
if assigned(fNetShare ) then EventMask := (EventMask or SHCNE_NETSHARE);
if assigned(fNetUnshare ) then EventMask := (EventMask or SHCNE_NETUNSHARE);
if assigned(fRenameFolder ) then EventMask := (EventMask or SHCNE_RENAMEFOLDER);
if assigned(fRenameItem ) then EventMask := (EventMask or SHCNE_RENAMEITEM);
if assigned(fRmDir ) then EventMask := (EventMask or SHCNE_RMDIR);
if assigned(fServerDisconnect ) then EventMask := (EventMask or SHCNE_SERVERDISCONNECT);
if assigned(fUpdateDir ) then EventMask := (EventMask or SHCNE_UPDATEDIR);
if assigned(fUpdateImage ) then EventMask := (EventMask or SHCNE_UPDATEIMAGE);
if assigned(fUpdateItem ) then EventMask := (EventMask or SHCNE_UPDATEITEM);
if EventMask = 0 then exit; if fHardDriveOnly
then for i := ord('A') to ord('Z') do begin
DriveLetter := char(i) + ':\';
if GetDriveType(pchar(DriveLetter)) = DRIVE_FIXED
then begin
inc(NotifyCount);
with NotifyArray[NotifyCount] do begin
SHILCreateFromPath
(pchar(DriveLetter),
addr(pidl),
Attributes);
pidlPath := pidl;
bWatchSubtree := true;
end;
end;
end
else begin
NotifyCount := 1;
with NotifyArray[1] do begin
pidlPath := nil;
bWatchSubtree := true;
end;
end;
NotifyPtr := addr(NotifyArray);
NotifyHandle := SHChangeNotifyRegister(
(Owner as TWinControl).Handle,
SHCNF_ACCEPT_INTERRUPTS +
SHCNF_ACCEPT_NON_INTERRUPTS,
EventMask,
fMessageNo,
NotifyCount,
NotifyPtr);
if NotifyHandle = 0
then begin
Stop;
raise Exception.Create('Could not register SHChangeNotify');
end;
end;
procedure TSHChangeNotify.Stop;
var
NotifyHandle : hwnd;
i : integer;
pidl : PITEMIDLIST;
begin
if csDesigning in ComponentState
then exit;
if NotifyCount > 0
then SHChangeNotifyDeregister(NotifyHandle);
for i := 1 to NotifyCount do begin
pidl := NotifyArray[i].PidlPath;
if AllocInterface.DidAlloc(pidl) = 1
then AllocInterface.Free(pidl);
end;
NotifyCount := 0;
end;
procedure TSHChangeNotify.WndProc(var msg: TMessage);
type
TPIDLLIST = record
pidlist : array[1..2] of PITEMIDLIST;
end;
PIDARRAY = ^TPIDLLIST;
var
Path1 : string;
Path2 : string;
ptr : PIDARRAY;
p1,p2 : PITEMIDLIST;
repeated : boolean;
p : integer;
event : longint;
parmcount : byte;
OneParmEvent : TOneParmEvent;
TwoParmEvent : TTwoParmEvent;
function ParsePidl (Pidl : PITEMIDLIST) : string;
begin
SetLength(result,MAX_PATH);
if not SHGetPathFromIDList(Pidl,pchar(result))
then result := '';
end;
begin
if Msg.Msg = WM_QUERYENDSESSION
then QueryEndSession(Msg);
if Msg.Msg = fMessageNo
then begin
OneParmEvent := nil;
TwoParmEvent := nil;
event := msg.LParam and ($7FFFFFFF);
case event of
SHCNE_ASSOCCHANGED : TwoParmEvent := fAssocChanged;
SHCNE_ATTRIBUTES : OneParmEvent := fAttributes;
SHCNE_CREATE : OneParmEvent := fCreate;
SHCNE_DELETE : OneParmEvent := fDelete;
SHCNE_DRIVEADD : OneParmEvent := fDriveAdd;
SHCNE_DRIVEADDGUI : OneParmEvent := fDriveAddGUI;
SHCNE_DRIVEREMOVED : OneParmEvent := fDriveRemoved;
SHCNE_MEDIAINSERTED : OneParmEvent := fMediaInserted;
SHCNE_MEDIAREMOVED : OneParmEvent := fMediaRemoved;
SHCNE_MKDIR : OneParmEvent := fMkDir;
SHCNE_NETSHARE : OneParmEvent := fNetShare;
SHCNE_NETUNSHARE : OneParmEvent := fNetUnshare;
SHCNE_RENAMEFOLDER : TwoParmEvent := fRenameFolder;
SHCNE_RENAMEITEM : TwoParmEvent := fRenameItem;
SHCNE_RMDIR : OneParmEvent := fRmDir;
SHCNE_SERVERDISCONNECT : OneParmEvent := fServerDisconnect;
SHCNE_UPDATEDIR : OneParmEvent := fUpdateDir;
SHCNE_UPDATEIMAGE : OneParmEvent := fUpdateImage;
SHCNE_UPDATEITEM : OneParmEvent := fUpdateItem;
else begin
OneParmEvent := nil; TwoParmEvent := nil;
end;
end;
if (assigned(OneParmEvent)) or (assigned(TwoParmEvent))
then begin
ptr := PIDARRAY(msg.wParam);
p1 := ptr^.pidlist[1];
try
SetLength(Path1,MAX_PATH);
Path1 := ParsePidl(p1);
p := pos(#00,Path1);
if p > 0
then SetLength(Path1,p - 1);
except
Path1 := '';
end;
p2 := ptr^.pidlist[2];
try
SetLength(Path2,MAX_PATH);
Path2 := ParsePidl(p2);
p := pos(#00,Path2);
if p > 0
then SetLength(Path2,p - 1);
except
Path2 := '';
end;
try
repeated := (PrevMsg = event)
and (uppercase(prevpath1) = uppercase(Path1))
and (uppercase(prevpath2) = uppercase(Path2))
except
repeated := false;
end;
PrevMsg := event;
PrevPath1 := Path1;
PrevPath2 := Path2;
case fTextCase of
tcUppercase : begin
Path1 := uppercase(Path1);
Path2 := uppercase(Path2);
end;
tcLowercase : begin
Path1 := lowercase(Path1);
Path2 := lowercase(Path2);
end;
end;
if not repeated then begin
case event of
SHCNE_ASSOCCHANGED,
SHCNE_RENAMEFOLDER,
SHCNE_RENAMEITEM : parmcount := 2;
else parmcount := 1;
end;
if parmcount = 1
then OneParmEvent(self, event, Path1)
else TwoParmEvent(self, event, Path1, Path2);
end;
end; end; OwnerWindowProc(Msg);
end;
procedure TSHChangeNotify.QueryEndSession(var msg: TMessage);
var
CanEndSession : boolean;
begin
CanEndSession := true;
if Assigned(fEndSessionQuery)
then fEndSessionQuery(Self, CanEndSession);
if CanEndSession
then begin
Stop;
Msg.Result := 1;
end
else Msg.Result := 0;
end;
destructor TSHChangeNotify.Destroy;
begin
if not (csDesigning in ComponentState)
then begin
if Assigned(Owner)
then (Owner as TWinControl).WindowProc := OwnerWindowProc;
Stop;
end;
inherited;
end;
end.