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