U盘插入和退出计算机时拦消息
'=============窗体代码=================
Private Declare Function RegisterDeviceNotification Lib "User32.dll " Alias _
"RegisterDeviceNotificationA " (ByVal hRecipient As Long, _
ByRef NotificationFilter As Any, ByVal Flags As Long) As Long
Private Declare Function UnregisterDeviceNotification Lib "User32.dll " ( _
ByVal Handle As Long) As Long
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type DEV_BROADCAST_DEVICEINTERFACE
dbcc_size As Long
dbcc_devicetype As Long
dbcc_reserved As Long
dbcc_classguid As Guid
dbcc_name As Long
End Type
Private hDevNotify As Long
Private Const DEVICE_NOTIFY_WINDOW_HANDLE As Long = &H0
Private Const DBT_DEVTYP_DEVICEINTERFACE As Long = &H5 ' Device interface class
Private Const DEVICE_NOTIFY_ALL_INTERFACE_CLASSES As Long = &H4
Private Sub Form_Load()
Dim NotificationFilter As DEV_BROADCAST_DEVICEINTERFACE
With NotificationFilter
.dbcc_size = Len(NotificationFilter)
.dbcc_devicetype = DBT_DEVTYP_DEVICEINTERFACE
End With
Call SubClass(Me.hWnd) '子类化
hDevNotify = RegisterDeviceNotification(Me.hWnd, NotificationFilter, _
DEVICE_NOTIFY_WINDOW_HANDLE Or DEVICE_NOTIFY_ALL_INTERFACE_CLASSES)
End Sub
Private Sub Form_Unload(ByRef Cancel As Integer)
Call UnregisterDeviceNotification(hDevNotify)
Call UnSubClass
End Sub
'=====================模块代码======================
Private Declare Function SetWindowLong Lib "User32.dll " Alias "SetWindowLongA " ( _
ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "User32.dll " Alias "CallWindowProcA " ( _
ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function StringFromGUID2 Lib "OLE32.dll " ( _
ByRef rGUID As Any, ByVal lpSz As String, ByVal cchMax As Long) As Long
Private Declare Function lstrcpyA Lib "Kernel32.dll " (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlenA Lib "Kernel32.dll " (ByVal lpString As Long) As Long
Private Declare Function GetDriveType Lib "Kernel32.dll " Alias "GetDriveTypeA " (ByVal nDrive As String) As Long
Private Declare Sub RtlMoveMemory Lib "Kernel32.dll " ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub GetDWord Lib "MSVBVM60.dll " Alias "GetMem4 " (ByRef inSrc As Any, ByRef inDst As Long)
Private Declare Sub GetWord Lib "MSVBVM60.dll " Alias "GetMem2 " (ByRef inSrc As Any, ByRef inDst As Integer)
Private Type DEV_BROADCAST_HDR
dbch_size As Long
dbch_devicetype As Long
dbch_reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Dim OldProc As Long
Dim WndHnd As Long
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_DEVICECHANGE As Long = &H219
Private Const DBT_DEVNODES_CHANGED As Long = &H7
Private Const DBT_DEVICEARRIVAL As Long = &H8000&
Private Const DBT_DEVICEREMOVECOMPLETE As Long = &H8004&
Private Const DBT_DEVTYP_VOLUME As Long = &H2 ' Logical volume
Private Const DBT_DEVTYP_DEVICEINTERFACE As Long = &H5 ' Device interface class
Private Const DBTF_MEDIA As Long = &H1 ' Media comings and goings
Private Const DBTF_NET As Long = &H2 ' Network volume
Private Const DRIVE_NO_ROOT_DIR As Long = 1
Private Const DRIVE_REMOVABLE As Long = 2
Private Const DRIVE_FIXED As Long = 3
Private Const DRIVE_REMOTE As Long = 4
Private Const DRIVE_CDROM As Long = 5
Private Const DRIVE_RAMDISK As Long = 6
Public Sub SubClass(ByVal inWnd As Long)
If (WndHnd) Then Call UnSubClass
OldProc = SetWindowLong(inWnd, GWL_WNDPROC, AddressOf WndProc)
WndHnd = inWnd
End Sub
Public Sub UnSubClass()
If (WndHnd = 0) Then Exit Sub
Call SetWindowLong(WndHnd, GWL_WNDPROC, OldProc)
WndHnd = 0
OldProc = 0
End Sub
Private Function WndProc(ByVal hWnd As Long, _
ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim DevBroadcastHeader As DEV_BROADCAST_HDR
Dim UnitMask As Long, Flags As Integer
Dim DeviceGUID As Guid
Dim DeviceNamePtr As Long
Dim DriveLetters As String
Dim LoopDrives As Long
If (uMsg = WM_DEVICECHANGE) Then
Select Case wParam
Case DBT_DEVICEARRIVAL, DBT_DEVICEREMOVECOMPLETE
If (lParam) Then ' Read generic DEV_BROADCAST_HDR structure
Call RtlMoveMemory(DevBroadcastHeader, ByVal lParam, Len(DevBroadcastHeader))
If (DevBroadcastHeader.dbch_devicetype = DBT_DEVTYP_VOLUME) Then
' Read end of DEV_BROADCAST_VOLUME structure
Call GetDWord(ByVal (lParam + Len(DevBroadcastHeader)), UnitMask)
Call GetWord(ByVal (lParam + Len(DevBroadcastHeader) + 4), Flags)
DriveLetters = UnitMaskToString(UnitMask)
For LoopDrives = 1 To Len(DriveLetters)
If wParam = DBT_DEVICEARRIVAL Then '如果是插入
If DriveTypeToString(GetDriveType(Mid$(DriveLetters, LoopDrives, 1) & ":\ ")) = "Removable " Then '如果是可移动磁盘
MsgBox "插入 "
End If
Else '否则是拔出
If DriveTypeToString(GetDriveType(Mid$(DriveLetters, LoopDrives, 1) & ":\ ")) = "Removable " Then '如果是可移动磁盘
MsgBox "拔出 "
End If
End If
Next LoopDrives
End If
End If
End Select
End If
WndProc = CallWindowProc(OldProc, hWnd, uMsg, wParam, lParam)
End Function
Private Function UnitMaskToString(ByVal inUnitMask As Long) As String
Dim LoopBits As Long
For LoopBits = 0 To 30
If (inUnitMask And (2 ^ LoopBits)) Then _
UnitMaskToString = UnitMaskToString & Chr$(Asc( "A ") + LoopBits)
Next LoopBits
End Function
Private Function DriveTypeToString(ByVal inDriveType As Long) As String '判断磁盘类型
Select Case inDriveType
Case DRIVE_NO_ROOT_DIR: DriveTypeToString = "No root directory " '??
Case DRIVE_REMOVABLE: DriveTypeToString = "Removable "
Case DRIVE_FIXED: DriveTypeToString = "Fixed "
Case DRIVE_REMOTE: DriveTypeToString = "Remote "
Case DRIVE_CDROM: DriveTypeToString = "CD-ROM "
Case DRIVE_RAMDISK: DriveTypeToString = "RAM disk "
Case Else: DriveTypeToString = "[ Unknown ] "
End Select
End Function
'从csdn的论坛的缺陷来看，复制、粘贴一次代码，所有引号中多一个空格。空格会导致dll入口失败