在win7下用delphi XE5 编写文件夹监视程序，在win7下可以检测到内存流输出的文件新建事件，但在winxp下却无法检测到。
在winxp下可以检测到鼠标右键新建文件事件。程序如下unit UnitDirMonitor;interfaceuses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.ShlObj, Winapi.ShellAPI, Vcl.StdCtrls,
Vcl.ExtCtrls, Vcl.Menus, Vcl.ImgList, VCL.FileCtrl;const
WM_SHNOTIFY = WM_USER + 10;type
TFormTestNotify = class(TForm)
MemoNotifyLog: TMemo;
Button1: TButton;
TrayIcon1: TTrayIcon;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
ImageList1: TImageList;
Button3: TButton;
N3: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure CreateParams(var Params:TCreateParams);override;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure TrayIcon1DblClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure N2Click(Sender: TObject);
procedure Button2Click(Sender: TObject);// 窗体悬浮方案 1
private
{ Private declarations }
FNotifyHandle: THandle;
procedure WMSHNOTIFY(var Msg: TMessage); message WM_SHNOTIFY;
procedure WndProc(var Message: TMessage);override;//窗体磁性吸附
procedure WMsyscommand(var msg: Twmsyscommand);message wm_syscommand;
public
{ Public declarations }
end;var
FormTestNotify: TFormTestNotify;
Dir:String;
implementation{$R *.dfm}type
NOTIFYREGISTER = packed record
pidlPath: PItemIDList;
bWatchSubtree: BOOL;
end;PNotifyRegister = ^NOTIFYREGISTER;{$WARNINGS OFF}
function SHChangeNotifyRegister(hWnd: HWND; dwFlags: Integer;
wEventMask: Cardinal; uMsg: UINT; cItems: Integer;
lpItems: PNotifyRegister): HWND; stdcall; external Shell32 index 2;function SHChangeNotifyDeregister(hWnd: HWND): Boolean; stdcall;
external Shell32 index 4;function SHILCreateFromPath(pszPath: PWideChar; ppidl: PItemIDList;
rgflnOut: PDWORD): HResult; stdcall; external Shell32 index 28;
{$WARNINGS ON}procedure TFormTestNotify.Button2Click(Sender: TObject);
begin
MemoNotifyLog.Clear;
end;procedure TFormTestNotify.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(Params);
//去掉窗口标题区
//Params.Style:=Params.Style and WS_CAPTION;
//Params.Style:=Params.Style or WS_POPUP;
//设为总在最上面
Params.ExStyle:=Params.ExStyle or WS_EX_TOPMOST;
//设Windows Owner为Desktop Window，连messagebox都跑到他后面！！
Params.WndParent:=GetDesktopWindow();
end;procedure TFormTestNotify.WMsyscommand(var msg : Twmsyscommand);
begin
if msg.CmdType = SC_MAXIMIZE then
begin
//showmessage('现在最大化')
end else if msg.CmdType = SC_MINIMIZE then
begin
FormTestNotify.Hide;
end; inherited;
end;procedure TFormTestNotify.WndProc(var Message: TMessage);
var
pos:PWINDOWPOS;
w,h,Rw:integer;//Rd
Gap:integer;
begin
case Message.Msg of
WM_WINDOWPOSCHANGING:begin
w:=screen.width;
h:=screen.height;
Gap:=30;
pos := PWINDOWPOS(Message.LParam); if (self.Height < h-(Gap*2)-1) then begin //如果窗体的高度小于吸附距离乘以2 则
if(pos^.y<Gap) then
pos^.y := 0;
end; if (self.Width < w-(Gap*2)-1) then begin //如果窗体的宽度小于吸附距离乘以2 则
if (pos^.x<Gap) then //如果窗体的左边距离小于等于吸附距离
pos^.x := 0;
Rw:=w-(self.Width+pos^.x); //计算窗体右边距离
if (Rw <=Gap) then
pos^.x:=w-self.Width;
end end;
end;
inherited WndProc(Message);
end;procedure TFormTestNotify.Button1Click(Sender: TObject);
begin
FormTestNotify.Hide;end;procedure TFormTestNotify.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//AnimateWindow(Self.Handle, 500,AW_BLEND or AW_HIDE);//窗体淡出
end;procedure TFormTestNotify.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
CanClose:=false;
Application.Minimize;
FormTestNotify.hide;
end;procedure TFormTestNotify.FormCreate(Sender: TObject);
var
vNotifyRegister: NOTIFYREGISTER;
vAttributes: WORD;
vItemIDList: PItemIDList;
begin
if SelectDirectory('Select Directory','',Dir) then
begin
SHILCreatefromPath(PWideChar(Dir), @vItemIDList, @vAttributes); //需将'C:\Temp'强制转换为WideChar类型。 vNotifyRegister.pidlPath := vItemIDList;
vNotifyRegister.bWatchSubtree := True; FNotifyHandle := SHChangeNotifyRegister(Handle,SHCNF_TYPE or SHCNF_IDLIST, SHCNE_ALLEVENTS or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, @vNotifyRegister); MemoNotifyLog.Clear;
end;end;procedure TFormTestNotify.FormShow(Sender: TObject);
begin
AnimateWindow(Self.Handle, 500, AW_BLEND or AW_ACTIVATE); //窗体淡入
//ANimateWindow(Handle,1000,AW_SLIDE+AW_VER_NEGATIVE); //窗体悬浮方案2 with Application do
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) and
not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);end;procedure TFormTestNotify.N1Click(Sender: TObject);
begin
FormTestNotify.Show;end;procedure TFormTestNotify.N2Click(Sender: TObject);
begin
application.Terminate;
end;procedure TFormTestNotify.TrayIcon1DblClick(Sender: TObject);
begin
FormTestNotify.Show;
end;procedure TFormTestNotify.WMSHNOTIFY(var Msg: TMessage);
type
PSHNOTIFYSTRUCT = ^SHNOTIFYSTRUCT;
SHNOTIFYSTRUCT = packed record
dwItem1: PItemIDList;
dwItem2: PItemIDList;
end;
var
vBuffer: array[0..MAX_PATH] of Char;
pidlItem: PSHNOTIFYSTRUCT;
S: string;
begin
pidlItem := PSHNOTIFYSTRUCT(Msg.wParam);
SHGetPathFromIDList(pidlItem.dwItem1, vBuffer);
S := vBuffer;
SHGetPathFromIDList(pidlItem.dwItem2, vBuffer);
case Msg.lParam of //根据参数设置提示消息
SHCNE_RENAMEITEM: S := 'Rename File' + S + 'to' + vBuffer;
SHCNE_CREATE:
begin
S := 'Create File:' + S;
end;
SHCNE_DELETE: S := 'Del File:' + S;
SHCNE_MKDIR: S := 'Create Dir:' + S;
SHCNE_RMDIR: S := 'Del Dir' + S;
SHCNE_MEDIAINSERTED: S := S + 'insert Removable Storage Media';
SHCNE_MEDIAREMOVED: S := S + 'Remove Removable Storage Media' + S + ' ' + vBuffer;
SHCNE_DRIVEREMOVED: S := 'Remove Drive' + S;
SHCNE_DRIVEADD: S := 'Add Drive' + S;
SHCNE_NETSHARE: S := 'Change Dir' + S + 'Attribution';
SHCNE_ATTRIBUTES: S := 'Change File Dir Attribution:' + S;
SHCNE_UPDATEDIR: S := 'Update Dir' + S;
SHCNE_UPDATEITEM: S := 'Update File:' + S;
SHCNE_SERVERDISCONNECT: S := 'Disconnect with Server' + S + ' ' + vBuffer;
SHCNE_UPDATEIMAGE: S := 'SHCNE_UPDATEIMAGE';
SHCNE_DRIVEADDGUI: S := 'SHCNE_DRIVEADDGUI';
SHCNE_RENAMEFOLDER: S := 'Rename Dir' + S + '为' + vBuffer;
SHCNE_FREESPACE: S := 'Disk Space Changed';
SHCNE_ASSOCCHANGED: S := 'Change File Link';
else
S := 'Unknown Operation' + IntToStr(Msg.lParam);
end;
MemoNotifyLog.Lines.Add(inttostr(Msg.lParam)+'-'+S); MemoNotifyLog.SelStart := Length(MemoNotifyLog.Text);
MemoNotifyLog.SelLength:= Length(MemoNotifyLog.Text);//0;
end;
end.
在winxp下可以检测到鼠标右键新建文件事件。程序如下unit UnitDirMonitor;interfaceuses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.ShlObj, Winapi.ShellAPI, Vcl.StdCtrls,
Vcl.ExtCtrls, Vcl.Menus, Vcl.ImgList, VCL.FileCtrl;const
WM_SHNOTIFY = WM_USER + 10;type
TFormTestNotify = class(TForm)
MemoNotifyLog: TMemo;
Button1: TButton;
TrayIcon1: TTrayIcon;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
ImageList1: TImageList;
Button3: TButton;
N3: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure CreateParams(var Params:TCreateParams);override;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure TrayIcon1DblClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure N2Click(Sender: TObject);
procedure Button2Click(Sender: TObject);// 窗体悬浮方案 1
private
{ Private declarations }
FNotifyHandle: THandle;
procedure WMSHNOTIFY(var Msg: TMessage); message WM_SHNOTIFY;
procedure WndProc(var Message: TMessage);override;//窗体磁性吸附
procedure WMsyscommand(var msg: Twmsyscommand);message wm_syscommand;
public
{ Public declarations }
end;var
FormTestNotify: TFormTestNotify;
Dir:String;
implementation{$R *.dfm}type
NOTIFYREGISTER = packed record
pidlPath: PItemIDList;
bWatchSubtree: BOOL;
end;PNotifyRegister = ^NOTIFYREGISTER;{$WARNINGS OFF}
function SHChangeNotifyRegister(hWnd: HWND; dwFlags: Integer;
wEventMask: Cardinal; uMsg: UINT; cItems: Integer;
lpItems: PNotifyRegister): HWND; stdcall; external Shell32 index 2;function SHChangeNotifyDeregister(hWnd: HWND): Boolean; stdcall;
external Shell32 index 4;function SHILCreateFromPath(pszPath: PWideChar; ppidl: PItemIDList;
rgflnOut: PDWORD): HResult; stdcall; external Shell32 index 28;
{$WARNINGS ON}procedure TFormTestNotify.Button2Click(Sender: TObject);
begin
MemoNotifyLog.Clear;
end;procedure TFormTestNotify.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(Params);
//去掉窗口标题区
//Params.Style:=Params.Style and WS_CAPTION;
//Params.Style:=Params.Style or WS_POPUP;
//设为总在最上面
Params.ExStyle:=Params.ExStyle or WS_EX_TOPMOST;
//设Windows Owner为Desktop Window，连messagebox都跑到他后面！！
Params.WndParent:=GetDesktopWindow();
end;procedure TFormTestNotify.WMsyscommand(var msg : Twmsyscommand);
begin
if msg.CmdType = SC_MAXIMIZE then
begin
//showmessage('现在最大化')
end else if msg.CmdType = SC_MINIMIZE then
begin
FormTestNotify.Hide;
end; inherited;
end;procedure TFormTestNotify.WndProc(var Message: TMessage);
var
pos:PWINDOWPOS;
w,h,Rw:integer;//Rd
Gap:integer;
begin
case Message.Msg of
WM_WINDOWPOSCHANGING:begin
w:=screen.width;
h:=screen.height;
Gap:=30;
pos := PWINDOWPOS(Message.LParam); if (self.Height < h-(Gap*2)-1) then begin //如果窗体的高度小于吸附距离乘以2 则
if(pos^.y<Gap) then
pos^.y := 0;
end; if (self.Width < w-(Gap*2)-1) then begin //如果窗体的宽度小于吸附距离乘以2 则
if (pos^.x<Gap) then //如果窗体的左边距离小于等于吸附距离
pos^.x := 0;
Rw:=w-(self.Width+pos^.x); //计算窗体右边距离
if (Rw <=Gap) then
pos^.x:=w-self.Width;
end end;
end;
inherited WndProc(Message);
end;procedure TFormTestNotify.Button1Click(Sender: TObject);
begin
FormTestNotify.Hide;end;procedure TFormTestNotify.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//AnimateWindow(Self.Handle, 500,AW_BLEND or AW_HIDE);//窗体淡出
end;procedure TFormTestNotify.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
CanClose:=false;
Application.Minimize;
FormTestNotify.hide;
end;procedure TFormTestNotify.FormCreate(Sender: TObject);
var
vNotifyRegister: NOTIFYREGISTER;
vAttributes: WORD;
vItemIDList: PItemIDList;
begin
if SelectDirectory('Select Directory','',Dir) then
begin
SHILCreatefromPath(PWideChar(Dir), @vItemIDList, @vAttributes); //需将'C:\Temp'强制转换为WideChar类型。 vNotifyRegister.pidlPath := vItemIDList;
vNotifyRegister.bWatchSubtree := True; FNotifyHandle := SHChangeNotifyRegister(Handle,SHCNF_TYPE or SHCNF_IDLIST, SHCNE_ALLEVENTS or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, @vNotifyRegister); MemoNotifyLog.Clear;
end;end;procedure TFormTestNotify.FormShow(Sender: TObject);
begin
AnimateWindow(Self.Handle, 500, AW_BLEND or AW_ACTIVATE); //窗体淡入
//ANimateWindow(Handle,1000,AW_SLIDE+AW_VER_NEGATIVE); //窗体悬浮方案2 with Application do
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) and
not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);end;procedure TFormTestNotify.N1Click(Sender: TObject);
begin
FormTestNotify.Show;end;procedure TFormTestNotify.N2Click(Sender: TObject);
begin
application.Terminate;
end;procedure TFormTestNotify.TrayIcon1DblClick(Sender: TObject);
begin
FormTestNotify.Show;
end;procedure TFormTestNotify.WMSHNOTIFY(var Msg: TMessage);
type
PSHNOTIFYSTRUCT = ^SHNOTIFYSTRUCT;
SHNOTIFYSTRUCT = packed record
dwItem1: PItemIDList;
dwItem2: PItemIDList;
end;
var
vBuffer: array[0..MAX_PATH] of Char;
pidlItem: PSHNOTIFYSTRUCT;
S: string;
begin
pidlItem := PSHNOTIFYSTRUCT(Msg.wParam);
SHGetPathFromIDList(pidlItem.dwItem1, vBuffer);
S := vBuffer;
SHGetPathFromIDList(pidlItem.dwItem2, vBuffer);
case Msg.lParam of //根据参数设置提示消息
SHCNE_RENAMEITEM: S := 'Rename File' + S + 'to' + vBuffer;
SHCNE_CREATE:
begin
S := 'Create File:' + S;
end;
SHCNE_DELETE: S := 'Del File:' + S;
SHCNE_MKDIR: S := 'Create Dir:' + S;
SHCNE_RMDIR: S := 'Del Dir' + S;
SHCNE_MEDIAINSERTED: S := S + 'insert Removable Storage Media';
SHCNE_MEDIAREMOVED: S := S + 'Remove Removable Storage Media' + S + ' ' + vBuffer;
SHCNE_DRIVEREMOVED: S := 'Remove Drive' + S;
SHCNE_DRIVEADD: S := 'Add Drive' + S;
SHCNE_NETSHARE: S := 'Change Dir' + S + 'Attribution';
SHCNE_ATTRIBUTES: S := 'Change File Dir Attribution:' + S;
SHCNE_UPDATEDIR: S := 'Update Dir' + S;
SHCNE_UPDATEITEM: S := 'Update File:' + S;
SHCNE_SERVERDISCONNECT: S := 'Disconnect with Server' + S + ' ' + vBuffer;
SHCNE_UPDATEIMAGE: S := 'SHCNE_UPDATEIMAGE';
SHCNE_DRIVEADDGUI: S := 'SHCNE_DRIVEADDGUI';
SHCNE_RENAMEFOLDER: S := 'Rename Dir' + S + '为' + vBuffer;
SHCNE_FREESPACE: S := 'Disk Space Changed';
SHCNE_ASSOCCHANGED: S := 'Change File Link';
else
S := 'Unknown Operation' + IntToStr(Msg.lParam);
end;
MemoNotifyLog.Lines.Add(inttostr(Msg.lParam)+'-'+S); MemoNotifyLog.SelStart := Length(MemoNotifyLog.Text);
MemoNotifyLog.SelLength:= Length(MemoNotifyLog.Text);//0;
end;
end.
fSources
Type: intOne or more of the following values that indicate the type of events for which to receive notifications. Note In earlier versions of the SDK, these flags are not defined in a header file and implementers must define these values themselves or use their numeric values directly. As of Windows Vista, these flags are defined in Shlobj.h.SHCNRF_InterruptLevel (0x0001)Interrupt level notifications from the file system.SHCNRF_ShellLevel (0x0002)Shell-level notifications from the shell.SHCNRF_RecursiveInterrupt (0x1000)