回复LJN(*)风流倜傥无人及，玉树偏又临风立(*)老兄，您的名字真是威风得紧哪，就是 臭婆娘的裹脚布都没您长... 言归正传：您说的我都知道，我也会添加，只不过我没学过C++，很多语句不懂。我试着写 了一点，现贴在下面，请大家指正： bas:Public prevWndProc As Long Public Const GWL_WNDPROC = (-4) Public Const WM_DEVICECHANGE = &H219 Public Const DBT_DEVICEARRIVAL = &H8000 Public Const DBT_DEVICEREMOVECOMPLETE = &H8004Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = WM_DEVICECHANGE Then Select Case wParam \ 65536 Case wParam = DBT_DEVICEARRIVAL
Form1.Text1.Text = "Closed" Case wParam = DBT_DEVICEREMOVECOMPLETE Form1.Text1.Text = "Opened" End Select End Ifform1: Private Sub Form_Load()'保存原来的WINDOW地址 prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC) '将子程序WNDPROC插队 SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc end sub运行结果：只能拦截到一种消息，其实确切的说如果我把 Case wParam = DBT_DEVICEARRIVAL 和 Case wParam = DBT_DEVICEREMOVECOMPLETE 对调一下位置，拦到的又会是光驱不可用的消息DBT_DEVICEREMOVECOMPLETE,也就说我现在 弹出和关上光驱都只拦到一个结果。虽然我不知道错在哪，但我直觉好象是参数写错了(wParam)，
我改了一下，并且已经试过了，没问题，可以监测光驱的弹出和关上，但不知道为什么， 我用常数代替数字就不行，如用DBT_DEVICEREMOVECOMPLETE代替32772 If Msg = WM_DEVICECHANGE Then '如果光驱弹出 If wParam = 32772 Then Form1.Text3.Text = "Opened"
ElseIf wParam = 32768 Then '如果光驱关上 Form1.Text3.Text = "Closed" End I还有，我还想找到具体变化的光驱盘符，但C++的代码我又看不懂，请 哪位高人帮我翻译成VB的代码，谢谢！char chFirstDriveFromMask (ULONG unitmask) { char i; for (i = 0; i < 26; ++i) //假设不会超过26个逻辑驱动器 { if (unitmask & 0x1) //看该驱动器的状态是否发生了变化 break; unitmask = unitmask >> 1; } return (i + 'A'); }
给你一段系统监测的软件，自己看吧，主要用到了Windows的未公开的函数 '模块mShellDefs Option Explicit' Brought to you by Brad Martinez ' http://members.aol.com/btmtz/vb ' http://www.mvps.org/ccrp' 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' Brought to you by Brad Martinez ' http://members.aol.com/btmtz/vb ' http://www.mvps.org/ccrp' Code was written in and formatted for 8pt MS San Serif' ==================================================================== ' Demonstrates how to receive shell change notifications (ala "what happens when the ' SHChangeNotify API is called?")' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2) ' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the ' assistance of James Holderness. For a complete (and probably more accurate) overview ' of shell change notifcations, please refer to James' "Shell Notifications" page at ' http://www.geocities.com/SiliconValley/4942/ ' ====================================================================Private m_hSHNotify As Long ' the one and only shell change notification handle for the desktop folder Private m_pidlDesktop As Long ' the desktop's pidl' User defined notiication message sent to the specified window's window proc. Public Const WM_SHNOTIFY = &H401' ====================================================================Public Type PIDLSTRUCT ' Fully qualified pidl (relative to the desktop folder) of the folder to monitor changes in. ' 0 can also be specifed for the desktop folder. pidl As Long ' Value specifying whether changes in the folder's subfolders trigger a change notification ' event (it's actually a Boolean, but we'll go Long because of VB's DWORD struct alignment). bWatchSubFolders As Long End TypeDeclare 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 - Handle of the window to receive the window message specified in uMsg.' uFlags - Flag that indicates the meaning of the dwItem1 and dwItem2 members of the ' SHNOTIFYSTRUCT (which is pointed to by the window procedure's wParam ' value when the specifed window message is received). This parameter can ' be one of the SHCN_ItemFlags enum values below. ' This interpretaion may be inaccurate as it appears pdils are almost alway returned ' in the SHNOTIFYSTRUCT. See James' site for more info...' dwEventId - Combination of SHCN_EventIDs enum values that specifies what events the ' specified window will be notified of. See below.
' uMsg - Window message to be used to identify receipt of a shell change notification. ' The message should *not* be a value that lies within the specifed window's ' message range ( i.e. BM_ messages for a button window) or that window may ' not receive all (if not any) notifications sent by the shell!!!' cItems - Count of PIDLSTRUCT structures in the array pointed to by the lpps param.' lpps - Pointer to an array of PIDLSTRUCT structures indicating what folder(s) to monitor ' changes in, and whether to watch the specified folder's subfolder.' If successful, returns a notification handle which must be passed to SHChangeNotifyDeregister ' when no longer used. Returns 0 otherwise.' Once the specified message is registered with SHChangeNotifyRegister, the specified ' window's function proc will be notified by the shell of the specified event in (and under) ' the folder(s) speciifed in apidl. On message receipt, wParam points to a SHNOTIFYSTRUCT ' and lParam contains the event's ID value.' The values in dwItem1 and dwItem2 are event specific. See the description of the values ' for the wEventId parameter of the documented SHChangeNotify API function. Type SHNOTIFYSTRUCT dwItem1 As Long dwItem2 As Long End Type' ...? 'Declare Function SHChangeNotifyUpdateEntryList Lib "shell32" Alias "#5" _ ' (ByVal hNotify As Long, _ ' ByVal Unknown As Long, _ ' ByVal cItem As Long, _ ' lpps As PIDLSTRUCT) As Boolean ' 'Declare Function SHChangeNotifyReceive Lib "shell32" Alias "#5" _ ' (ByVal hNotify As Long, _ ' ByVal uFlags As SHCN_ItemFlags, _ ' ByVal dwItem1 As Long, _ ' ByVal dwItem2 As Long) As Long' Closes the notification handle returned from a call to SHChangeNotifyRegister. ' Returns True if succeful, False otherwise. Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean' ====================================================================' This function should be called by any app that changes anything in the shell. ' The shell will then notify each "notification registered" window of this action. Declare Sub SHChangeNotify Lib "shell32" _ (ByVal wEventId As SHCN_EventIDs, _ ByVal uFlags As SHCN_ItemFlags, _ ByVal dwItem1 As Long, _ ByVal dwItem2 As Long)' Shell notification event IDsPublic Enum SHCN_EventIDs SHCNE_RENAMEITEM = &H1 ' (D) A nonfolder item has been renamed. SHCNE_CREATE = &H2 ' (D) A nonfolder item has been created. SHCNE_DELETE = &H4 ' (D) A nonfolder item has been deleted. SHCNE_MKDIR = &H8 ' (D) A folder item has been created. SHCNE_RMDIR = &H10 ' (D) A folder item has been removed. SHCNE_MEDIAINSERTED = &H20 ' (G) Storage media has been inserted into a drive. SHCNE_MEDIAREMOVED = &H40 ' (G) Storage media has been removed from a drive. SHCNE_DRIVEREMOVED = &H80 ' (G) A drive has been removed. SHCNE_DRIVEADD = &H100 ' (G) A drive has been added. SHCNE_NETSHARE = &H200 ' A folder on the local computer is being shared via the network. SHCNE_NETUNSHARE = &H400 ' A folder on the local computer is no longer being shared via the network. SHCNE_ATTRIBUTES = &H800 ' (D) The attributes of an item or folder have changed. SHCNE_UPDATEDIR = &H1000 ' (D) The contents of an existing folder have changed, but the folder still exists and has not been renamed. SHCNE_UPDATEITEM = &H2000 ' (D) An existing nonfolder item has changed, but the item still exists and has not been renamed. SHCNE_SERVERDISCONNECT = &H4000 ' The computer has disconnected from a server. SHCNE_UPDATEIMAGE = &H8000& ' (G) An image in the system image list has changed. SHCNE_DRIVEADDGUI = &H10000 ' (G) A drive has been added and the shell should create a new window for the drive. SHCNE_RENAMEFOLDER = &H20000 ' (D) The name of a folder has changed. SHCNE_FREESPACE = &H40000 ' (G) The amount of free space on a drive has changed.#If (WIN32_IE >= &H400) Then SHCNE_EXTENDED_EVENT = &H4000000 ' (G) Not currently used. #End If ' WIN32_IE >= &H0400 SHCNE_ASSOCCHANGED = &H8000000 ' (G) A file type association has changed. SHCNE_DISKEVENTS = &H2381F ' Specifies a combination of all of the disk event identifiers. (D) SHCNE_GLOBALEVENTS = &HC0581E0 ' Specifies a combination of all of the global event identifiers. (G) SHCNE_ALLEVENTS = &H7FFFFFFF SHCNE_INTERRUPT = &H80000000 ' The specified event occurred as a result of a system interrupt. ' It is stripped out before the clients of SHCNNotify_ see it. End Enum#If (WIN32_IE >= &H400) Then ' ??? Public Const SHCNEE_ORDERCHANGED = &H2 ' dwItem2 is the pidl of the changed folder #End If' Notification flags' uFlags & SHCNF_TYPE is an ID which indicates what dwItem1 and dwItem2 mean Public Enum SHCN_ItemFlags SHCNF_IDLIST = &H0 ' LPITEMIDLIST SHCNF_PATHA = &H1 ' path name SHCNF_PRINTERA = &H2 ' printer friendly name SHCNF_DWORD = &H3 ' DWORD SHCNF_PATHW = &H5 ' path name SHCNF_PRINTERW = &H6 ' printer friendly name SHCNF_TYPE = &HFF ' Flushes the system event buffer. The function does not return until the system is ' finished processing the given event. SHCNF_FLUSH = &H1000 ' Flushes the system event buffer. The function returns immediately regardless of ' whether the system is finished processing the given event. 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 '' Registers the one and only shell change notification.Public Function SHNotify_Register(hWnd As Long) As Boolean Dim ps As PIDLSTRUCT
' If we don't already have a notification going... If (m_hSHNotify = 0) Then
' Get the pidl for the desktop folder. m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP) If m_pidlDesktop Then
' Fill the one and only PIDLSTRUCT, we're watching ' desktop and all of the it's subfolders, everything... ps.pidl = m_pidlDesktop ps.bWatchSubFolders = True
' Register the notification, specifying that we want the dwItem1 and dwItem2 ' members of the SHNOTIFYSTRUCT to be pidls. We're watching all events. m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _ SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _ WM_SHNOTIFY, 1, ps) Debug.Print Hex(SHCNF_TYPE Or SHCNF_IDLIST) Debug.Print Hex(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT) Debug.Print m_hSHNotify SHNotify_Register = CBool(m_hSHNotify)
Else ' If something went wrong... Call CoTaskMemFree(m_pidlDesktop)
End If ' m_pidlDesktop End If ' (m_hSHNotify = 0)
End Function' Unregisters the one and only shell change notification.Public Function SHNotify_Unregister() As Boolean
' If we have a registered notification handle. If m_hSHNotify Then ' Unregister it. If the call is successful, zero the handle's variable, ' free and zero the the desktop's pidl. If SHChangeNotifyDeregister(m_hSHNotify) Then m_hSHNotify = 0 Call CoTaskMemFree(m_pidlDesktop) m_pidlDesktop = 0 SHNotify_Unregister = True End If End IfEnd Function' Returns the event string associated with the specified event ID value.Public Function SHNotify_GetEventStr(dwEventID As Long) As String Dim sEvent As String
Select Case dwEventID Case SHCNE_RENAMEITEM: sEvent = "SHCNE_RENAMEITEM" ' = &H1" Case SHCNE_CREATE: sEvent = "SHCNE_CREATE" ' = &H2" Case SHCNE_DELETE: sEvent = "SHCNE_DELETE" ' = &H4" Case SHCNE_MKDIR: sEvent = "SHCNE_MKDIR" ' = &H8" Case SHCNE_RMDIR: sEvent = "SHCNE_RMDIR" ' = &H10" Case SHCNE_MEDIAINSERTED: sEvent = "SHCNE_MEDIAINSERTED" ' = &H20" Case SHCNE_MEDIAREMOVED: sEvent = "SHCNE_MEDIAREMOVED" ' = &H40" Case SHCNE_DRIVEREMOVED: sEvent = "SHCNE_DRIVEREMOVED" ' = &H80" Case SHCNE_DRIVEADD: sEvent = "SHCNE_DRIVEADD" ' = &H100" Case SHCNE_NETSHARE: sEvent = "SHCNE_NETSHARE" ' = &H200" Case SHCNE_NETUNSHARE: sEvent = "SHCNE_NETUNSHARE" ' = &H400" Case SHCNE_ATTRIBUTES: sEvent = "SHCNE_ATTRIBUTES" ' = &H800" Case SHCNE_UPDATEDIR: sEvent = "SHCNE_UPDATEDIR" ' = &H1000" Case SHCNE_UPDATEITEM: sEvent = "SHCNE_UPDATEITEM" ' = &H2000" Case SHCNE_SERVERDISCONNECT: sEvent = "SHCNE_SERVERDISCONNECT" ' = &H4000" Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE" ' = &H8000&" Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI" ' = &H10000" Case SHCNE_RENAMEFOLDER: sEvent = "SHCNE_RENAMEFOLDER" ' = &H20000" Case SHCNE_FREESPACE: sEvent = "SHCNE_FREESPACE" ' = &H40000"
#If (WIN32_IE >= &H400) Then Case SHCNE_EXTENDED_EVENT: sEvent = "SHCNE_EXTENDED_EVENT" ' = &H4000000" #End If ' WIN32_IE >= &H0400
Case SHCNE_ASSOCCHANGED: sEvent = "SHCNE_ASSOCCHANGED" ' = &H8000000"
Case SHCNE_DISKEVENTS: sEvent = "SHCNE_DISKEVENTS" ' = &H2381F" Case SHCNE_GLOBALEVENTS: sEvent = "SHCNE_GLOBALEVENTS" ' = &HC0581E0" Case SHCNE_ALLEVENTS: sEvent = "SHCNE_ALLEVENTS" ' = &H7FFFFFFF" Case SHCNE_INTERRUPT: sEvent = "SHCNE_INTERRUPT" ' = &H80000000" End Select
SHNotify_GetEventStr = sEventEnd Function '模块mSubClass Option Explicit' Brought to you by Brad Martinez ' http://members.aol.com/btmtz/vb ' http://www.mvps.org/ccrp' 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)
End Function 'Form1 Option Explicit ' ' Brought to you by Brad Martinez ' http://members.aol.com/btmtz/vb ' http://www.mvps.org/ccrp ' ' Code was written in and formatted for 8pt MS San Serif ' ' ==================================================================== ' Demonstrates how to receive shell change notifications (ala "what happens when the ' SHChangeNotify API is called?") ' ' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2) ' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the ' assistance of James Holderness. For a complete (and probably more accurate) overview ' of shell change notifcations, please refer to James' "Shell Notifications" page at ' http://www.geocities.com/SiliconValley/4942/ ' ==================================================================== '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
在程序里面,我可以对光盘进行预读,比如我可以在光盘里面查找*.txt(也可以是其他类型文件)文本文件,给查找加一个标志符,如果找到了,那么光驱是关闭的,如果找不到或者发生预读错误,那么光驱是关闭的.
臭婆娘的裹脚布都没您长...
言归正传：您说的我都知道，我也会添加，只不过我没学过C++，很多语句不懂。我试着写
了一点，现贴在下面，请大家指正：
bas:Public prevWndProc As Long
Public Const GWL_WNDPROC = (-4)
Public Const WM_DEVICECHANGE = &H219
Public Const DBT_DEVICEARRIVAL = &H8000
Public Const DBT_DEVICEREMOVECOMPLETE = &H8004Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_DEVICECHANGE Then
Select Case wParam \ 65536
Case wParam = DBT_DEVICEARRIVAL
Form1.Text1.Text = "Closed"
Case wParam = DBT_DEVICEREMOVECOMPLETE
Form1.Text1.Text = "Opened"
End Select
End Ifform1:
Private Sub Form_Load()'保存原来的WINDOW地址
prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC)
'将子程序WNDPROC插队
SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc
end sub运行结果：只能拦截到一种消息，其实确切的说如果我把
Case wParam = DBT_DEVICEARRIVAL
和
Case wParam = DBT_DEVICEREMOVECOMPLETE
对调一下位置，拦到的又会是光驱不可用的消息DBT_DEVICEREMOVECOMPLETE,也就说我现在
弹出和关上光驱都只拦到一个结果。虽然我不知道错在哪，但我直觉好象是参数写错了(wParam)，
我用常数代替数字就不行，如用DBT_DEVICEREMOVECOMPLETE代替32772
If Msg = WM_DEVICECHANGE Then
'如果光驱弹出
If wParam = 32772 Then
Form1.Text3.Text = "Opened"
ElseIf wParam = 32768 Then
'如果光驱关上
Form1.Text3.Text = "Closed"
End I还有，我还想找到具体变化的光驱盘符，但C++的代码我又看不懂，请
哪位高人帮我翻译成VB的代码，谢谢！char chFirstDriveFromMask (ULONG unitmask)
{
char i;
for (i = 0; i < 26; ++i) //假设不会超过26个逻辑驱动器
{
if (unitmask & 0x1) //看该驱动器的状态是否发生了变化
break;
unitmask = unitmask >> 1;
}
return (i + 'A');
}
'模块mShellDefs
Option Explicit' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp' 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' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp' Code was written in and formatted for 8pt MS San Serif' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================Private m_hSHNotify As Long ' the one and only shell change notification handle for the desktop folder
Private m_pidlDesktop As Long ' the desktop's pidl' User defined notiication message sent to the specified window's window proc.
Public Const WM_SHNOTIFY = &H401' ====================================================================Public Type PIDLSTRUCT
' Fully qualified pidl (relative to the desktop folder) of the folder to monitor changes in.
' 0 can also be specifed for the desktop folder.
pidl As Long
' Value specifying whether changes in the folder's subfolders trigger a change notification
' event (it's actually a Boolean, but we'll go Long because of VB's DWORD struct alignment).
bWatchSubFolders As Long
End TypeDeclare 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 - Handle of the window to receive the window message specified in uMsg.' uFlags - Flag that indicates the meaning of the dwItem1 and dwItem2 members of the
' SHNOTIFYSTRUCT (which is pointed to by the window procedure's wParam
' value when the specifed window message is received). This parameter can
' be one of the SHCN_ItemFlags enum values below.
' This interpretaion may be inaccurate as it appears pdils are almost alway returned
' in the SHNOTIFYSTRUCT. See James' site for more info...' dwEventId - Combination of SHCN_EventIDs enum values that specifies what events the
' specified window will be notified of. See below.
' uMsg - Window message to be used to identify receipt of a shell change notification.
' The message should *not* be a value that lies within the specifed window's
' message range ( i.e. BM_ messages for a button window) or that window may
' not receive all (if not any) notifications sent by the shell!!!' cItems - Count of PIDLSTRUCT structures in the array pointed to by the lpps param.' lpps - Pointer to an array of PIDLSTRUCT structures indicating what folder(s) to monitor
' changes in, and whether to watch the specified folder's subfolder.' If successful, returns a notification handle which must be passed to SHChangeNotifyDeregister
' when no longer used. Returns 0 otherwise.' Once the specified message is registered with SHChangeNotifyRegister, the specified
' window's function proc will be notified by the shell of the specified event in (and under)
' the folder(s) speciifed in apidl. On message receipt, wParam points to a SHNOTIFYSTRUCT
' and lParam contains the event's ID value.' The values in dwItem1 and dwItem2 are event specific. See the description of the values
' for the wEventId parameter of the documented SHChangeNotify API function.
Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type' ...?
'Declare Function SHChangeNotifyUpdateEntryList Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal Unknown As Long, _
' ByVal cItem As Long, _
' lpps As PIDLSTRUCT) As Boolean
'
'Declare Function SHChangeNotifyReceive Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal uFlags As SHCN_ItemFlags, _
' ByVal dwItem1 As Long, _
' ByVal dwItem2 As Long) As Long' Closes the notification handle returned from a call to SHChangeNotifyRegister.
' Returns True if succeful, False otherwise.
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean' ====================================================================' This function should be called by any app that changes anything in the shell.
' The shell will then notify each "notification registered" window of this action.
Declare Sub SHChangeNotify Lib "shell32" _
(ByVal wEventId As SHCN_EventIDs, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwItem1 As Long, _
ByVal dwItem2 As Long)' Shell notification event IDsPublic Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1 ' (D) A nonfolder item has been renamed.
SHCNE_CREATE = &H2 ' (D) A nonfolder item has been created.
SHCNE_DELETE = &H4 ' (D) A nonfolder item has been deleted.
SHCNE_MKDIR = &H8 ' (D) A folder item has been created.
SHCNE_RMDIR = &H10 ' (D) A folder item has been removed.
SHCNE_MEDIAINSERTED = &H20 ' (G) Storage media has been inserted into a drive.
SHCNE_MEDIAREMOVED = &H40 ' (G) Storage media has been removed from a drive.
SHCNE_DRIVEREMOVED = &H80 ' (G) A drive has been removed.
SHCNE_DRIVEADD = &H100 ' (G) A drive has been added.
SHCNE_NETSHARE = &H200 ' A folder on the local computer is being shared via the network.
SHCNE_NETUNSHARE = &H400 ' A folder on the local computer is no longer being shared via the network.
SHCNE_ATTRIBUTES = &H800 ' (D) The attributes of an item or folder have changed.
SHCNE_UPDATEDIR = &H1000 ' (D) The contents of an existing folder have changed, but the folder still exists and has not been renamed.
SHCNE_UPDATEITEM = &H2000 ' (D) An existing nonfolder item has changed, but the item still exists and has not been renamed.
SHCNE_SERVERDISCONNECT = &H4000 ' The computer has disconnected from a server.
SHCNE_UPDATEIMAGE = &H8000& ' (G) An image in the system image list has changed.
SHCNE_DRIVEADDGUI = &H10000 ' (G) A drive has been added and the shell should create a new window for the drive.
SHCNE_RENAMEFOLDER = &H20000 ' (D) The name of a folder has changed.
SHCNE_FREESPACE = &H40000 ' (G) The amount of free space on a drive has changed.#If (WIN32_IE >= &H400) Then
SHCNE_EXTENDED_EVENT = &H4000000 ' (G) Not currently used.
#End If ' WIN32_IE >= &H0400 SHCNE_ASSOCCHANGED = &H8000000 ' (G) A file type association has changed. SHCNE_DISKEVENTS = &H2381F ' Specifies a combination of all of the disk event identifiers. (D)
SHCNE_GLOBALEVENTS = &HC0581E0 ' Specifies a combination of all of the global event identifiers. (G)
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000 ' The specified event occurred as a result of a system interrupt.
' It is stripped out before the clients of SHCNNotify_ see it.
End Enum#If (WIN32_IE >= &H400) Then ' ???
Public Const SHCNEE_ORDERCHANGED = &H2 ' dwItem2 is the pidl of the changed folder
#End If' Notification flags' uFlags & SHCNF_TYPE is an ID which indicates what dwItem1 and dwItem2 mean
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0 ' LPITEMIDLIST
SHCNF_PATHA = &H1 ' path name
SHCNF_PRINTERA = &H2 ' printer friendly name
SHCNF_DWORD = &H3 ' DWORD
SHCNF_PATHW = &H5 ' path name
SHCNF_PRINTERW = &H6 ' printer friendly name
SHCNF_TYPE = &HFF
' Flushes the system event buffer. The function does not return until the system is
' finished processing the given event.
SHCNF_FLUSH = &H1000
' Flushes the system event buffer. The function returns immediately regardless of
' whether the system is finished processing the given event.
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
'' Registers the one and only shell change notification.Public Function SHNotify_Register(hWnd As Long) As Boolean
Dim ps As PIDLSTRUCT
' If we don't already have a notification going...
If (m_hSHNotify = 0) Then
' Get the pidl for the desktop folder.
m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If m_pidlDesktop Then
' Fill the one and only PIDLSTRUCT, we're watching
' desktop and all of the it's subfolders, everything...
ps.pidl = m_pidlDesktop
ps.bWatchSubFolders = True
' Register the notification, specifying that we want the dwItem1 and dwItem2
' members of the SHNOTIFYSTRUCT to be pidls. We're watching all events.
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, ps)
Debug.Print Hex(SHCNF_TYPE Or SHCNF_IDLIST)
Debug.Print Hex(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT)
Debug.Print m_hSHNotify
SHNotify_Register = CBool(m_hSHNotify)
Else
' If something went wrong...
Call CoTaskMemFree(m_pidlDesktop)
End If ' m_pidlDesktop
End If ' (m_hSHNotify = 0)
End Function' Unregisters the one and only shell change notification.Public Function SHNotify_Unregister() As Boolean
' If we have a registered notification handle.
If m_hSHNotify Then
' Unregister it. If the call is successful, zero the handle's variable,
' free and zero the the desktop's pidl.
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_pidlDesktop)
m_pidlDesktop = 0
SHNotify_Unregister = True
End If
End IfEnd Function' Returns the event string associated with the specified event ID value.Public Function SHNotify_GetEventStr(dwEventID As Long) As String
Dim sEvent As String
Select Case dwEventID
Case SHCNE_RENAMEITEM: sEvent = "SHCNE_RENAMEITEM" ' = &H1"
Case SHCNE_CREATE: sEvent = "SHCNE_CREATE" ' = &H2"
Case SHCNE_DELETE: sEvent = "SHCNE_DELETE" ' = &H4"
Case SHCNE_MKDIR: sEvent = "SHCNE_MKDIR" ' = &H8"
Case SHCNE_RMDIR: sEvent = "SHCNE_RMDIR" ' = &H10"
Case SHCNE_MEDIAINSERTED: sEvent = "SHCNE_MEDIAINSERTED" ' = &H20"
Case SHCNE_MEDIAREMOVED: sEvent = "SHCNE_MEDIAREMOVED" ' = &H40"
Case SHCNE_DRIVEREMOVED: sEvent = "SHCNE_DRIVEREMOVED" ' = &H80"
Case SHCNE_DRIVEADD: sEvent = "SHCNE_DRIVEADD" ' = &H100"
Case SHCNE_NETSHARE: sEvent = "SHCNE_NETSHARE" ' = &H200"
Case SHCNE_NETUNSHARE: sEvent = "SHCNE_NETUNSHARE" ' = &H400"
Case SHCNE_ATTRIBUTES: sEvent = "SHCNE_ATTRIBUTES" ' = &H800"
Case SHCNE_UPDATEDIR: sEvent = "SHCNE_UPDATEDIR" ' = &H1000"
Case SHCNE_UPDATEITEM: sEvent = "SHCNE_UPDATEITEM" ' = &H2000"
Case SHCNE_SERVERDISCONNECT: sEvent = "SHCNE_SERVERDISCONNECT" ' = &H4000"
Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE" ' = &H8000&"
Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI" ' = &H10000"
Case SHCNE_RENAMEFOLDER: sEvent = "SHCNE_RENAMEFOLDER" ' = &H20000"
Case SHCNE_FREESPACE: sEvent = "SHCNE_FREESPACE" ' = &H40000"
#If (WIN32_IE >= &H400) Then
Case SHCNE_EXTENDED_EVENT: sEvent = "SHCNE_EXTENDED_EVENT" ' = &H4000000"
#End If ' WIN32_IE >= &H0400
Case SHCNE_ASSOCCHANGED: sEvent = "SHCNE_ASSOCCHANGED" ' = &H8000000"
Case SHCNE_DISKEVENTS: sEvent = "SHCNE_DISKEVENTS" ' = &H2381F"
Case SHCNE_GLOBALEVENTS: sEvent = "SHCNE_GLOBALEVENTS" ' = &HC0581E0"
Case SHCNE_ALLEVENTS: sEvent = "SHCNE_ALLEVENTS" ' = &H7FFFFFFF"
Case SHCNE_INTERRUPT: sEvent = "SHCNE_INTERRUPT" ' = &H80000000"
End Select
SHNotify_GetEventStr = sEventEnd Function
'模块mSubClass
Option Explicit' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp' 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
'
' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp
'
' Code was written in and formatted for 8pt MS San Serif
'
' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")
'
' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================
'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
监视CDROM的空盘关门，虽然有这么一个BUG，但这个例子还是一个相当
不错的东东，再次谢谢这位老兄!不过说句掏肠子的话，我还是想把原来的那个例子弄懂来，因为它毕竟
MSDN中自带的，更何况别人都懂了，我也想懂，虽然有一定的困难，但
我还是喜欢刨根刨到底，也正是因为我有这个脾气，所以在知识的海洋
中还没淹死...还请大家成全小弟!首先多谢上边那位老兄的不辞辛苦将这么长的代码贴出来...我发现这个例子也有不完善的地方，如只能监视CDROM的弹出，而不能
监视CDROM的空盘关门，虽然有这么一个BUG，但这个例子还是一个相当
不错的东东，再次谢谢这位老兄!不过说句掏肠子的话，我还是想把原来的那个例子弄懂来，因为它毕竟
MSDN中自带的，更何况别人都懂了，我也想懂，虽然有一定的困难，但
我还是喜欢刨根刨到底，也正是因为我有这个脾气，所以在知识的海洋
中还没淹死...还请大家成全小弟!