发一个源程序给你,这是重网上找来的,可别嫌长,直接应用就可以了。探讨可发email:[email protected]
窗体form1中的代码:Option Explicit
Private Sub Form_Load()
If SubClass(hWnd) Then
If IsIDE Then
Text1.Text = vbCrLf & _
"一个 Windows的文件目录操作即时监视程序," & vbCrLf & "可以监视在Explore中的重命名、新建、删除文" & _
vbCrLf & "件或目录;改变文件关联;插入、取出CD和添加" & vbCrLf & "删除网络共享都可以被该程序记录下来。"
End If
Call SHNotify_Register(hWnd)
'Else
' Text1 = "Uh..., it's supposed to work... :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End SubPrivate Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End FunctionPrivate Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End SubPrivate Sub Form_Resize()
On Error GoTo Out
Text1.Move 0, 0, ScaleWidth, ScaleHeight
Out:
End SubPublic Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT
sOut = SHNotify_GetEventStr(lParam) & vbCrLf
' Fill the SHNOTIFYSTRUCT from it's pointer.
MoveMemory shns, ByVal wParam, Len(shns)
' lParam is the ID of the notication event, one of the SHCN_EventIDs.
Select Case lParam
' ================================================================
' For the SHCNE_FREESPACE event, dwItem1 points to what looks like a 10 byte
' struct. The first two bytes are the size of the struct, and the next two members
' equate to SHChangeNotify's dwItem1 and dwItem2 params. The dwItem1 member
' is a bitfield indicating which drive(s) had it's (their) free space changed. The bitfield
' is identical to the bitfield returned from a GetLogicalDrives call, i.e, bit 0 = A:\, bit
' 1 = B:\, 2, = C:\, etc. Since VB does DWORD alignment when MoveMemory'ing
' to a struct, we'll extract the bitfield directly from it's memory location.
Case SHCNE_FREESPACE
Dim dwDriveBits As Long
Dim wHighBit As Integer
Dim wBit As Integer
MoveMemory dwDriveBits, ByVal shns.dwItem1 + 2, 4 ' Get the zero based position of the highest bit set in the bitmask
' (essentially determining the value's highest complete power of 2).
' Use floating point division (we want the exact values from the Logs)
' and remove the fractional value (the fraction indicates the value of
' the last incomplete power of 2, which means the bit isn't set).
wHighBit = Int(Log(dwDriveBits) / Log(2))
For wBit = 0 To wHighBit
' If the bit is set...
If (2 ^ wBit) And dwDriveBits Then
' The bit is set, get it's drive string
sOut = sOut & Chr$(vbKeyA + wBit) & ":\" & vbCrLf End If
Next
' ================================================================
' shns.dwItem1 also points to a 10 byte struct. The struct's second member (after the
' struct's first WORD size member) points to the system imagelist index of the image
' that was updated.
Case SHCNE_UPDATEIMAGE
Dim iImage As Long
MoveMemory iImage, ByVal shns.dwItem1 + 2, 4
sOut = sOut & "Index of image in system imagelist: " & iImage & vbCrLf
' ================================================================
' Everything else except SHCNE_ATTRIBUTES is the pidl(s) of the changed item(s).
' For SHCNE_ATTRIBUTES, neither item is used. See the description of the values
' for the wEventId parameter of the SHChangeNotify API function for more info.
Case Else
Dim sDisplayname As String
If shns.dwItem1 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem1)
If Len(sDisplayname) Then
sOut = sOut & "first item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "first item path: " & GetPathFromPIDL(shns.dwItem1) & vbCrLf
Else
sOut = sOut & "first item is invalid" & vbCrLf
End If
End If
If shns.dwItem2 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem2)
If Len(sDisplayname) Then
sOut = sOut & "second item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "second item path: " & GetPathFromPIDL(shns.dwItem2) & vbCrLf
Else
sOut = sOut & "second item is invalid" & vbCrLf
End If
End If
End Select
Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
tmrFlashMe = TrueEnd SubPrivate Sub tmrFlashMe_Timer() ' initial settings: Interval = 1, Enabled = False
Static nCount As Integer
If nCount = 0 Then tmrFlashMe.Interval = 200
nCount = nCount + 1
Call FlashWindow(hWnd, True)
' Reset everything after 3 flash cycles
If nCount = 6 Then
nCount = 0
tmrFlashMe.Interval = 1
tmrFlashMe = False
End IfEnd Sub
模块mShellDefs中的代码:
Option Explicit' Code was written in and formatted for 8pt MS San Serif' ====================================================================Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Public Const MAX_PATH = 260' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
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 ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
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' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End TypeDeclare 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 LongPublic Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End TypeEnum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder IDPublic 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' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.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' Returns a path from only an absolute pidl (relative to the desktop)Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function' Returns the string before first null char encountered (if any) from an ANSII string.Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function
模块mShellNotify中的代码,这是实现托盘的。
Option Explicit' Code was written in and formatted for 8pt MS San Serif' ====================================================================Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Public Const MAX_PATH = 260' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
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 ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
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' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End TypeDeclare 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 LongPublic Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End TypeEnum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder IDPublic 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' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.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' Returns a path from only an absolute pidl (relative to the desktop)Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function' Returns the string before first null char encountered (if any) from an ANSII string.Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function
模块mSubClass中的代码
Option Explicit' Code was written in and formatted for 8pt MS San SerifPrivate Const WM_NCDESTROY = &H82Private 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 LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)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 LongPrivate Const OLDWNDPROC = "OldWndProc"
'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 FunctionPublic 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 IfEnd FunctionPublic 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
窗体form1中的代码:Option Explicit
Private Sub Form_Load()
If SubClass(hWnd) Then
If IsIDE Then
Text1.Text = vbCrLf & _
"一个 Windows的文件目录操作即时监视程序," & vbCrLf & "可以监视在Explore中的重命名、新建、删除文" & _
vbCrLf & "件或目录;改变文件关联;插入、取出CD和添加" & vbCrLf & "删除网络共享都可以被该程序记录下来。"
End If
Call SHNotify_Register(hWnd)
'Else
' Text1 = "Uh..., it's supposed to work... :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End SubPrivate Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End FunctionPrivate Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End SubPrivate Sub Form_Resize()
On Error GoTo Out
Text1.Move 0, 0, ScaleWidth, ScaleHeight
Out:
End SubPublic Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT
sOut = SHNotify_GetEventStr(lParam) & vbCrLf
' Fill the SHNOTIFYSTRUCT from it's pointer.
MoveMemory shns, ByVal wParam, Len(shns)
' lParam is the ID of the notication event, one of the SHCN_EventIDs.
Select Case lParam
' ================================================================
' For the SHCNE_FREESPACE event, dwItem1 points to what looks like a 10 byte
' struct. The first two bytes are the size of the struct, and the next two members
' equate to SHChangeNotify's dwItem1 and dwItem2 params. The dwItem1 member
' is a bitfield indicating which drive(s) had it's (their) free space changed. The bitfield
' is identical to the bitfield returned from a GetLogicalDrives call, i.e, bit 0 = A:\, bit
' 1 = B:\, 2, = C:\, etc. Since VB does DWORD alignment when MoveMemory'ing
' to a struct, we'll extract the bitfield directly from it's memory location.
Case SHCNE_FREESPACE
Dim dwDriveBits As Long
Dim wHighBit As Integer
Dim wBit As Integer
MoveMemory dwDriveBits, ByVal shns.dwItem1 + 2, 4 ' Get the zero based position of the highest bit set in the bitmask
' (essentially determining the value's highest complete power of 2).
' Use floating point division (we want the exact values from the Logs)
' and remove the fractional value (the fraction indicates the value of
' the last incomplete power of 2, which means the bit isn't set).
wHighBit = Int(Log(dwDriveBits) / Log(2))
For wBit = 0 To wHighBit
' If the bit is set...
If (2 ^ wBit) And dwDriveBits Then
' The bit is set, get it's drive string
sOut = sOut & Chr$(vbKeyA + wBit) & ":\" & vbCrLf End If
Next
' ================================================================
' shns.dwItem1 also points to a 10 byte struct. The struct's second member (after the
' struct's first WORD size member) points to the system imagelist index of the image
' that was updated.
Case SHCNE_UPDATEIMAGE
Dim iImage As Long
MoveMemory iImage, ByVal shns.dwItem1 + 2, 4
sOut = sOut & "Index of image in system imagelist: " & iImage & vbCrLf
' ================================================================
' Everything else except SHCNE_ATTRIBUTES is the pidl(s) of the changed item(s).
' For SHCNE_ATTRIBUTES, neither item is used. See the description of the values
' for the wEventId parameter of the SHChangeNotify API function for more info.
Case Else
Dim sDisplayname As String
If shns.dwItem1 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem1)
If Len(sDisplayname) Then
sOut = sOut & "first item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "first item path: " & GetPathFromPIDL(shns.dwItem1) & vbCrLf
Else
sOut = sOut & "first item is invalid" & vbCrLf
End If
End If
If shns.dwItem2 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem2)
If Len(sDisplayname) Then
sOut = sOut & "second item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "second item path: " & GetPathFromPIDL(shns.dwItem2) & vbCrLf
Else
sOut = sOut & "second item is invalid" & vbCrLf
End If
End If
End Select
Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
tmrFlashMe = TrueEnd SubPrivate Sub tmrFlashMe_Timer() ' initial settings: Interval = 1, Enabled = False
Static nCount As Integer
If nCount = 0 Then tmrFlashMe.Interval = 200
nCount = nCount + 1
Call FlashWindow(hWnd, True)
' Reset everything after 3 flash cycles
If nCount = 6 Then
nCount = 0
tmrFlashMe.Interval = 1
tmrFlashMe = False
End IfEnd Sub
模块mShellDefs中的代码:
Option Explicit' Code was written in and formatted for 8pt MS San Serif' ====================================================================Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Public Const MAX_PATH = 260' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
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 ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
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' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End TypeDeclare 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 LongPublic Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End TypeEnum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder IDPublic 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' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.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' Returns a path from only an absolute pidl (relative to the desktop)Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function' Returns the string before first null char encountered (if any) from an ANSII string.Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function
模块mShellNotify中的代码,这是实现托盘的。
Option Explicit' Code was written in and formatted for 8pt MS San Serif' ====================================================================Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Public Const MAX_PATH = 260' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As SHSpecialFolderIDs, _
pidl As Long) As Long' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
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 ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
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' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End TypeDeclare 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 LongPublic Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End TypeEnum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder IDPublic 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' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.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' Returns a path from only an absolute pidl (relative to the desktop)Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function' Returns the string before first null char encountered (if any) from an ANSII string.Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function
模块mSubClass中的代码
Option Explicit' Code was written in and formatted for 8pt MS San SerifPrivate Const WM_NCDESTROY = &H82Private 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 LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)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 LongPrivate Const OLDWNDPROC = "OldWndProc"
'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 FunctionPublic 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 IfEnd FunctionPublic 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
解决方案 »
- VB 对游戏后台鼠标单击问题
- 使用API关闭程序出错
- 问个小问题
- 急!谁有aRes报表控件的序列号。回答正确者100分,绝不食言
- FSO对象在98中.
- 我vb做com+组件,速度很慢,为什么?
- 怎样使图片框中的图随图片框的大小同比例变化呢?
- COM+里的事务,ADO里的事务,SQL Server里的事务有什么不同?
- 这个论坛真的没有一个所谓的高手??版主好象也很久没有出现过了,看来,是要换到其他论坛了,郁闷中……,不信你们看……
- 请问在VB中怎样实现加载的位图大小随着PictureBox的大小而自动改变?谢谢!!
- vb高手快来看一看,帮我解决以下这个比较难的问题
- 请问怎样调用一个窗体结束后,此窗体向调用者返回一个结果值就像msgbox窗体一样,返回一个VbYes或VbNo之类的数值
错了是源程序,我没有办法调试
[email protected]
你的代码拷错了吧,怎么模块mShellDefs中的代码和模块mShellNotify中的代码是一模一样的呀。
介绍的是如何利用Windows未公开函数实现系统文件操作监视功能。利用该功能可以对
Windows下的任何文件操作,包括建立文件、文件夹;删除文件;改变文件大小等操作
都可以纪录在案。
http://www.csdn.net/develop/read_article.asp?id=3545
http://www.csdn.net/develop/read_article.asp?id=3487
使用了其它不同的机制