系統文件操作監視功能
Windows未公開函數揭密--之三
這次介紹的是如何利用Windows未公開函數實現系統文件操作監視功能。利用該功能可以對Windows下的任何文件
操作,包括建立文件、文件夾;刪除文件;改變文件大小等操作都可以紀錄在案。
首先來介紹實現上面操作的兩個未公開函數:SHChangeNotifyRegister和SHChangeNotifyDeregister
,SHChangeNotifyRegister函數的定義如下:
Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long
其中參數hWnd指定接受系統通告的窗口句柄,參數uMsg指定消息值,如果函數調用成功,系統就會將hWnd指定的
窗口加入到系統通告鏈中,並且返回系統通告句柄。當有建立文件等系統操作發生時,系統會向hWnd指定的窗口發送
uMsg消息,關於其它參數,會在下面的程序中說明。函數SHChangeNotifyDeregister的定義如下:
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
(ByVal hNotify As Long) As Boolean
其中參數hNotify指定系統通告的句柄。
下面是操作的具體的VB範例:
首先建立一個新的工程,在Form1中加入一個TextBox控件。在Form1的代碼窗口之中加入以下代碼:
Option Explicit
Private Sub Form_Load()
If SubClass(hWnd) Then '改變Form1的消息處理函數
If IsIDE Then
Text1.Text = vbCrLf & _
"一個 Windows的文件目錄操作即時監視程序," & vbCrLf & "可以監視在Explore中的重命名、新建、刪除文" & _
vbCrLf & "件或目錄;改變文件關聯;插入、取出CD和添加" & vbCrLf & "刪除網絡共享都可以被該程序記錄下來。"
End If
Call SHNotify_Register(hWnd)
Else
Text1 = "系統不支持操作監視程序 :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End Sub
Private Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End Function
Private Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End Sub
Public Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT
Dim sDisplayname1 As String
Dim sDisplayname2 As String
MoveMemory shns, ByVal wParam, Len(shns)
If shns.dwItem1 Then
sDisplayname1 = GetDisplayNameFromPIDL(shns.dwItem1)
End If
If shns.dwItem2 Then
sDisplayname2 = GetDisplayNameFromPIDL(shns.dwItem2)
End If
sOut = SHNotify_GetEventStr(sDisplayname1, sDisplayname2, lParam) & vbCrLf
Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
End Sub
然後在工程中加入三個模塊(Bas)文件,將三個文件分別保存爲mDef.Bas、mShell.Bas、mSub.Bas。在mDef.Bas中加入以下代碼:
'mDef.Bas包含Shell操作的函數和數據類型的定義
Option Explicit
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
pSource As Any, ByVal dwLength As Long)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Const MAX_PATH = 260
Public Const NOERROR = 0
'SHGetSpecialFolderLocation獲得某一個特殊的目錄的位置,如果函數調用成功返回NOERROR
'或者一個OLE錯誤
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long
Public Enum SHSpecialFolderIDs '列出所有Windows下特殊文件夾的ID
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
'SHGetPathFromIDList函數將一個Item轉換爲文件路徑
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
'SHGetFileInfoPidl函數獲得某個文件對象的信息。
Declare Function SHGetFileInfoPidl Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pidl As Long, _
ByVal dwFileAttributes As Long, _
psfib As SHFILEINFOBYTE, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long
Public Type SHFILEINFOBYTE
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type
Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long
Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Enum SHGFI_flags
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
End Enum
'根據一個特定文件夾對象的ID獲得它的目錄pidl
Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long
Dim pidl As Long
If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then
GetPIDLFromFolderID = pidl
End If
End Function
Public Function GetDisplayNameFromPIDL(pidl As Long) As String
Dim sfib As SHFILEINFOBYTE
If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then
GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
End If
End Function
Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function
Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
GetStrFromBufferA = sz
End If
End Function
在mShell.Bas中加入以下代碼:
'mShell.Bas函數包含註冊和反註冊系統通告以及文件夾信息轉換的函數
Option Explicit
Private m_hSHNotify As Long '系統消息通告句柄
Private m_pidlDesktop As Long
'定義系統通告的消息值
Public Const WM_SHNOTIFY = &H401
Public Type PIDLSTRUCT
pidl As Long
bWatchSubFolders As Long
End Type
Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long
Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
(ByVal hNotify As Long) As Boolean
Declare Sub SHChangeNotify Lib "shell32" _
(ByVal wEventId As SHCN_EventIDs, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwItem1 As Long, _
ByVal dwItem2 As Long)
Public Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1
SHCNE_CREATE = &H2
SHCNE_DELETE = &H4
SHCNE_MKDIR = &H8
SHCNE_RMDIR = &H10
SHCNE_MEDIAINSERTED = &H20
SHCNE_MEDIAREMOVED = &H40
SHCNE_DRIVEREMOVED = &H80
SHCNE_DRIVEADD = &H100
SHCNE_NETSHARE = &H200
SHCNE_NETUNSHARE = &H400
SHCNE_ATTRIBUTES = &H800
SHCNE_UPDATEDIR = &H1000
SHCNE_UPDATEITEM = &H2000
SHCNE_SERVERDISCONNECT = &H4000
SHCNE_UPDATEIMAGE = &H8000&
SHCNE_DRIVEADDGUI = &H10000
SHCNE_RENAMEFOLDER = &H20000
SHCNE_FREESPACE = &H40000
SHCNE_ASSOCCHANGED = &H8000000
SHCNE_DISKEVENTS = &H2381F
SHCNE_GLOBALEVENTS = &HC0581E0
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000
End Enum
#If (WIN32_IE >= &H400) Then
Public Const SHCNEE_ORDERCHANGED = &H2
#End If
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0
SHCNF_PATHA = &H1
SHCNF_PRINTERA = &H2
SHCNF_DWORD = &H3
SHCNF_PATHW = &H5
SHCNF_PRINTERW = &H6
SHCNF_TYPE = &HFF
SHCNF_FLUSH = &H1000
SHCNF_FLUSHNOWAIT = &H2000
#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
Public Function SHNotify_Register(hWnd As Long) As Boolean
Dim ps As PIDLSTRUCT
If (m_hSHNotify = 0) Then
m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If m_pidlDesktop Then
ps.pidl = m_pidlDesktop
ps.bWatchSubFolders = True
'註冊Windows監視,將獲得的句柄保存到m_hSHNotify中
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, ps)
SHNotify_Register = CBool(m_hSHNotify)
Else
Call CoTaskMemFree(m_pidlDesktop)
End If
End If
End Function
Public Function SHNotify_Unregister() As Boolean
If m_hSHNotify Then
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_pidlDesktop)
m_pidlDesktop = 0
SHNotify_Unregister = True
End If
End If
End Function
Public Function SHNotify_GetEventStr(strPath1, strPath2 As String, dwEventID As Long) As String
Dim sEvent As String
Select Case dwEventID
Case SHCNE_RENAMEITEM: sEvent = "重命名文件" + strPath1 + "爲" + strPath2
Case SHCNE_CREATE: sEvent = "建立文件 文件名:" + strPath1
Case SHCNE_DELETE: sEvent = "刪除文件 文件名:" + strPath1
Case SHCNE_MKDIR: sEvent = "新建目錄 目錄名:" + strPath1
Case SHCNE_RMDIR: sEvent = "刪除目錄 目錄名:" + strPath1
Case SHCNE_MEDIAINSERTED: sEvent = strPath1 + "中插入可移動存儲介質"
Case SHCNE_MEDIAREMOVED: sEvent = strPath1 + "中移去可移動存儲介質"
Case SHCNE_DRIVEREMOVED: sEvent = "移去驅動器" + strPath1
Case SHCNE_DRIVEADD: sEvent = "添加驅動器" + strPath1
Case SHCNE_NETSHARE: sEvent = "改變目錄" + strPath1 + "的共享屬性"
Case SHCNE_UPDATEDIR: sEvent = "更新目錄" + strPath1
Case SHCNE_UPDATEITEM: sEvent = "更新文件 文件名:" + strPath1
Case SHCNE_SERVERDISCONNECT: sEvent = "斷開與服務器的連" + strPath1 + " " + strPath2
Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE"
Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI"
Case SHCNE_RENAMEFOLDER: sEvent = "重命名文件夾" + strPath1 + "爲" + strPath2
Case SHCNE_FREESPACE: sEvent = "磁盤空間大小改變"
Case SHCNE_ASSOCCHANGED: sEvent = "改變文件關聯"
End Select
SHNotify_GetEventStr = sEvent
End Function
在mSub.Bas中加入以下代碼:
'mSub函數包括窗口的消息處理函數
Option Explicit
Private Const WM_NCDESTROY = &H82
Private Const GWL_WNDPROC = (-4)
Private Const OLDWNDPROC = "OldWndProc"
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal _
hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Public Function SubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean
If (GetProp(hWnd, OLDWNDPROC) = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If
End If
If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call UnSubClass(hWnd)
MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
End If
End Function
Public Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If RemoveProp(hWnd, OLDWNDPROC) Then
UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
End If
End If
End Function
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As _
Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_SHNOTIFY '處理系統消息通告函數
Call Form1.NotificationReceipt(wParam, lParam)
Case WM_NCDESTROY
Call UnSubClass(hWnd)
MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"
End Select
WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function
保存文件,然後運行程序,然後你可以在Explore中試着建立或者刪除一個文件或者文件夾,在Form中可以看到
你所做的操作已經被紀錄並且顯示到TextBox中了。
現在分析以下上面的程序,上面的程序首先調用SHChangeNotifyRegister函數將Form添加到系統消息通告鏈中,
並利用SetWindowLong函數改變Form的缺省的消息處理函數,當接受到系統通告消息後,根據傳遞的參數獲得系統通
告的內容並且顯示在文本窗口中。退出程序時調用SHChangeNotifyDeregister函數註銷系統消息通告。
這次介紹的是如何利用Windows未公開函數實現系統文件操作監視功能。利用該功能可以對Windows下的任何文件
操作,包括建立文件、文件夾;刪除文件;改變文件大小等操作都可以紀錄在案。
首先來介紹實現上面操作的兩個未公開函數:SHChangeNotifyRegister和SHChangeNotifyDeregister
,SHChangeNotifyRegister函數的定義如下:
Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long
其中參數hWnd指定接受系統通告的窗口句柄,參數uMsg指定消息值,如果函數調用成功,系統就會將hWnd指定的
窗口加入到系統通告鏈中,並且返回系統通告句柄。當有建立文件等系統操作發生時,系統會向hWnd指定的窗口發送
uMsg消息,關於其它參數,會在下面的程序中說明。函數SHChangeNotifyDeregister的定義如下:
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
(ByVal hNotify As Long) As Boolean
其中參數hNotify指定系統通告的句柄。
下面是操作的具體的VB範例:
首先建立一個新的工程,在Form1中加入一個TextBox控件。在Form1的代碼窗口之中加入以下代碼:
Option Explicit
Private Sub Form_Load()
If SubClass(hWnd) Then '改變Form1的消息處理函數
If IsIDE Then
Text1.Text = vbCrLf & _
"一個 Windows的文件目錄操作即時監視程序," & vbCrLf & "可以監視在Explore中的重命名、新建、刪除文" & _
vbCrLf & "件或目錄;改變文件關聯;插入、取出CD和添加" & vbCrLf & "刪除網絡共享都可以被該程序記錄下來。"
End If
Call SHNotify_Register(hWnd)
Else
Text1 = "系統不支持操作監視程序 :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End Sub
Private Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End Function
Private Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End Sub
Public Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT
Dim sDisplayname1 As String
Dim sDisplayname2 As String
MoveMemory shns, ByVal wParam, Len(shns)
If shns.dwItem1 Then
sDisplayname1 = GetDisplayNameFromPIDL(shns.dwItem1)
End If
If shns.dwItem2 Then
sDisplayname2 = GetDisplayNameFromPIDL(shns.dwItem2)
End If
sOut = SHNotify_GetEventStr(sDisplayname1, sDisplayname2, lParam) & vbCrLf
Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
End Sub
然後在工程中加入三個模塊(Bas)文件,將三個文件分別保存爲mDef.Bas、mShell.Bas、mSub.Bas。在mDef.Bas中加入以下代碼:
'mDef.Bas包含Shell操作的函數和數據類型的定義
Option Explicit
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
pSource As Any, ByVal dwLength As Long)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Const MAX_PATH = 260
Public Const NOERROR = 0
'SHGetSpecialFolderLocation獲得某一個特殊的目錄的位置,如果函數調用成功返回NOERROR
'或者一個OLE錯誤
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long
Public Enum SHSpecialFolderIDs '列出所有Windows下特殊文件夾的ID
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
'SHGetPathFromIDList函數將一個Item轉換爲文件路徑
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
'SHGetFileInfoPidl函數獲得某個文件對象的信息。
Declare Function SHGetFileInfoPidl Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pidl As Long, _
ByVal dwFileAttributes As Long, _
psfib As SHFILEINFOBYTE, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long
Public Type SHFILEINFOBYTE
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type
Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long
Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Enum SHGFI_flags
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
End Enum
'根據一個特定文件夾對象的ID獲得它的目錄pidl
Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long
Dim pidl As Long
If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then
GetPIDLFromFolderID = pidl
End If
End Function
Public Function GetDisplayNameFromPIDL(pidl As Long) As String
Dim sfib As SHFILEINFOBYTE
If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then
GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
End If
End Function
Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function
Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
GetStrFromBufferA = sz
End If
End Function
在mShell.Bas中加入以下代碼:
'mShell.Bas函數包含註冊和反註冊系統通告以及文件夾信息轉換的函數
Option Explicit
Private m_hSHNotify As Long '系統消息通告句柄
Private m_pidlDesktop As Long
'定義系統通告的消息值
Public Const WM_SHNOTIFY = &H401
Public Type PIDLSTRUCT
pidl As Long
bWatchSubFolders As Long
End Type
Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long
Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
(ByVal hNotify As Long) As Boolean
Declare Sub SHChangeNotify Lib "shell32" _
(ByVal wEventId As SHCN_EventIDs, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwItem1 As Long, _
ByVal dwItem2 As Long)
Public Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1
SHCNE_CREATE = &H2
SHCNE_DELETE = &H4
SHCNE_MKDIR = &H8
SHCNE_RMDIR = &H10
SHCNE_MEDIAINSERTED = &H20
SHCNE_MEDIAREMOVED = &H40
SHCNE_DRIVEREMOVED = &H80
SHCNE_DRIVEADD = &H100
SHCNE_NETSHARE = &H200
SHCNE_NETUNSHARE = &H400
SHCNE_ATTRIBUTES = &H800
SHCNE_UPDATEDIR = &H1000
SHCNE_UPDATEITEM = &H2000
SHCNE_SERVERDISCONNECT = &H4000
SHCNE_UPDATEIMAGE = &H8000&
SHCNE_DRIVEADDGUI = &H10000
SHCNE_RENAMEFOLDER = &H20000
SHCNE_FREESPACE = &H40000
SHCNE_ASSOCCHANGED = &H8000000
SHCNE_DISKEVENTS = &H2381F
SHCNE_GLOBALEVENTS = &HC0581E0
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000
End Enum
#If (WIN32_IE >= &H400) Then
Public Const SHCNEE_ORDERCHANGED = &H2
#End If
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0
SHCNF_PATHA = &H1
SHCNF_PRINTERA = &H2
SHCNF_DWORD = &H3
SHCNF_PATHW = &H5
SHCNF_PRINTERW = &H6
SHCNF_TYPE = &HFF
SHCNF_FLUSH = &H1000
SHCNF_FLUSHNOWAIT = &H2000
#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
Public Function SHNotify_Register(hWnd As Long) As Boolean
Dim ps As PIDLSTRUCT
If (m_hSHNotify = 0) Then
m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If m_pidlDesktop Then
ps.pidl = m_pidlDesktop
ps.bWatchSubFolders = True
'註冊Windows監視,將獲得的句柄保存到m_hSHNotify中
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, ps)
SHNotify_Register = CBool(m_hSHNotify)
Else
Call CoTaskMemFree(m_pidlDesktop)
End If
End If
End Function
Public Function SHNotify_Unregister() As Boolean
If m_hSHNotify Then
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_pidlDesktop)
m_pidlDesktop = 0
SHNotify_Unregister = True
End If
End If
End Function
Public Function SHNotify_GetEventStr(strPath1, strPath2 As String, dwEventID As Long) As String
Dim sEvent As String
Select Case dwEventID
Case SHCNE_RENAMEITEM: sEvent = "重命名文件" + strPath1 + "爲" + strPath2
Case SHCNE_CREATE: sEvent = "建立文件 文件名:" + strPath1
Case SHCNE_DELETE: sEvent = "刪除文件 文件名:" + strPath1
Case SHCNE_MKDIR: sEvent = "新建目錄 目錄名:" + strPath1
Case SHCNE_RMDIR: sEvent = "刪除目錄 目錄名:" + strPath1
Case SHCNE_MEDIAINSERTED: sEvent = strPath1 + "中插入可移動存儲介質"
Case SHCNE_MEDIAREMOVED: sEvent = strPath1 + "中移去可移動存儲介質"
Case SHCNE_DRIVEREMOVED: sEvent = "移去驅動器" + strPath1
Case SHCNE_DRIVEADD: sEvent = "添加驅動器" + strPath1
Case SHCNE_NETSHARE: sEvent = "改變目錄" + strPath1 + "的共享屬性"
Case SHCNE_UPDATEDIR: sEvent = "更新目錄" + strPath1
Case SHCNE_UPDATEITEM: sEvent = "更新文件 文件名:" + strPath1
Case SHCNE_SERVERDISCONNECT: sEvent = "斷開與服務器的連" + strPath1 + " " + strPath2
Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE"
Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI"
Case SHCNE_RENAMEFOLDER: sEvent = "重命名文件夾" + strPath1 + "爲" + strPath2
Case SHCNE_FREESPACE: sEvent = "磁盤空間大小改變"
Case SHCNE_ASSOCCHANGED: sEvent = "改變文件關聯"
End Select
SHNotify_GetEventStr = sEvent
End Function
在mSub.Bas中加入以下代碼:
'mSub函數包括窗口的消息處理函數
Option Explicit
Private Const WM_NCDESTROY = &H82
Private Const GWL_WNDPROC = (-4)
Private Const OLDWNDPROC = "OldWndProc"
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal _
hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Public Function SubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean
If (GetProp(hWnd, OLDWNDPROC) = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If
End If
If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call UnSubClass(hWnd)
MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
End If
End Function
Public Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If RemoveProp(hWnd, OLDWNDPROC) Then
UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
End If
End If
End Function
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As _
Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_SHNOTIFY '處理系統消息通告函數
Call Form1.NotificationReceipt(wParam, lParam)
Case WM_NCDESTROY
Call UnSubClass(hWnd)
MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"
End Select
WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function
保存文件,然後運行程序,然後你可以在Explore中試着建立或者刪除一個文件或者文件夾,在Form中可以看到
你所做的操作已經被紀錄並且顯示到TextBox中了。
現在分析以下上面的程序,上面的程序首先調用SHChangeNotifyRegister函數將Form添加到系統消息通告鏈中,
並利用SetWindowLong函數改變Form的缺省的消息處理函數,當接受到系統通告消息後,根據傳遞的參數獲得系統通
告的內容並且顯示在文本窗口中。退出程序時調用SHChangeNotifyDeregister函數註銷系統消息通告。
發表評論
所有評論
還沒有人評論,想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.