module1.bas

监测U盘拔插 可以检测到U盘的插入和拔出动作

Attribute VB_Name = "Module1"
Option Explicit
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Const GWL_WNDPROC = -4
Const WM_DEVICECHANGE As Long = &H219
Const DBT_DEVICEARRIVAL As Long = &H8000&
Const DBT_DEVICEREMOVECOMPLETE As Long = &H8004&
'设备类型：逻辑卷标
Const DBT_DEVTYP_VOLUME As Long = &H2
'与WM_DEVICECHANGE消息相关联的结构体头部信息
Private Type DEV_BROADCAST_HDR
lSize As Long
lDevicetype As Long '设备类型
lReserved As Long
End Type
'设备为逻辑卷时对应的结构体信息
Private Type DEV_BROADCAST_VOLUME
lSize As Long
lDevicetype As Long
lReserved As Long
lUnitMask As Long '和逻辑卷标对应的掩码
iFlag As Integer
End Type
Public info As DEV_BROADCAST_HDR
Public info_volume As DEV_BROADCAST_VOLUME
Public PrevProc As Long

Public Sub HookForm(F As Form)
 PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHookForm(F As Form)
 SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc
End Sub

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Select Case uMsg
 '插入USB DISK 则接收到此消息
 Case WM_DEVICECHANGE
  Form1.Text1.Text = wParam
  Form1.Text2.Text = lParam
 'Form1.Text1.Text = "发现新硬件"
 If wParam = DBT_DEVICEARRIVAL Then
 '若插入USBDISK或者映射网络盘等则
 'info.lDevicetype =2
 '即DBT_DEVTYP_VOLUME
 '利用参数lParam获取结构体头部信息
 CopyMemory info, ByVal lParam, Len(info)
 If info.lDevicetype = DBT_DEVTYP_VOLUME Then
 CopyMemory info_volume, ByVal lParam, Len(info_volume)
 '检测到有逻辑卷添加到系统中，则显示该设备根目录下全部文件名
 ListFiles Chr(GetDriveName(info_volume.lUnitMask)) & ":\", Form1.List1
 End If
 End If
 If wParam = DBT_DEVICEREMOVECOMPLETE Then
 '若移走USBDISK或者映射网络盘等则
 'info.lDevicetype =2
 '即DBT_DEVTYP_VOLUME
 '利用参数lParam获取结构体头部信息
 CopyMemory info, ByVal lParam, Len(info)
 If info.lDevicetype = DBT_DEVTYP_VOLUME Then
 CopyMemory info_volume, ByVal lParam, Len(info_volume)
 '清除LIST中的内容
 Form1.List1.Clear
 End If
 End If
 End Select
 ' 调用原来的窗体消息处理函数
 WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
End Function

'根据输入的32位LONG型数据（只有一位为1）返回对应的卷标的ASCII数值
'规则是1：A、2：B、4：C等等
Function GetDriveName(ByVal lUnitMask As Long) As Byte
Dim i As Long
i = 0
While lUnitMask Mod 2 <> 1
 lUnitMask = lUnitMask \ 2
 i = i + 1
Wend
GetDriveName = Asc("A") + i
End Function
'显示插入逻辑卷根目录的文件名列表，需要在工程里引用Microsoft Scripting Runtime库。
'Function ListFiles(strPath As String, ByRef list As ListBox)'
'Dim fso As New Scripting.FileSystemObject
'Dim objFolder As Folder
' Dim objFile As File
' Set objFolder = fso.GetFolder(strPath)
' For Each objFile In objFolder.Files
' list.AddItem objFile.Name
' Next
'End Function