|
|
做一个小程序，需要实时检测是否插入指定的U盘，用到了WMI时间，想到以前的帖子http://club.excelhome.net/forum.php?mod=viewthread&tid=733445&extra=page%3D1%26filter%3Dauthor%26orderby%3Ddateline%26digest%3D1%26digest%3D1%26orderby%3Ddateline最后没有介绍订阅事件，精简一下移植到vba，简单介绍一下，放到这里权当补充吧。
声明一下，关于用U盘做钥匙盘及禁用U盘，论坛已经有很多讨论，这里只是演示wmi事件的使用，无意引入以上讨论。两个示例都是禁用U盘，但只对代码运行后插入U盘起作用，之前插入的不起作用。
1、监测是否插入U盘，如果有就自动弹出插入的U盘。
Public WithEvents wmiEvent As SWbemSink
Private Declare Function DeviceIoControl Lib "kernel32.dll" (ByVal hDevice As Long, ByRef dwIoControlCode As Long, _
ByRef lpInBuffer As Any, ByVal nInBufferSize As Long, ByRef lpOutBuffer As Any, ByVal nOutBufferSize As Long, _
ByRef lpBytesReturned As Long, ByRef lpOverlapped As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByRef lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const EJECT_MEDIA As Long = &H202
Private Const FILE_DEVICE_MASS_STORAGE As Long = &H2D&
Private Sub CommandButton1_Click()
Dim wmiLocator As New SWbemLocator
Dim wmiServices As SWbemServices
Set wmiEvent = New SWbemSink
Set wmiServices = wmiLocator.ConnectServer(".", "root\CIMV2")
wmiServices.ExecNotificationQueryAsync wmiEvent, "SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE TargetInstance ISA 'Win32_LogicalDisk'"
End Sub
Private Sub CommandButton2_Click()
If Not wmiEvent Is Nothing Then
wmiEvent.Cancel
Set wmiEvent = Nothing
End If
End Sub
Private Sub Eject(ByVal sName As String)
Dim lngFunction As Long
Dim lngReturn As Long
Dim lngHand As Long
Dim lngFlag As Long
lngFlag = GENERIC_READ Or GENERIC_WRITE
Do
lngHand = CreateFile(sName, lngFlag, 0, ByVal CLng(0), 3, ByVal CLng(0), ByVal CLng(0))
If lngHand <> -1 Then Exit Do
Loop
lngFunction = (FILE_DEVICE_MASS_STORAGE * (2 ^ 16)) Or (1 * (2 ^ 14)) Or (EJECT_MEDIA * (2 ^ 2)) Or 0
DeviceIoControl lngHand, ByVal lngFunction, 0, 0, 0, 0, lngReturn, ByVal 0
End Sub
Private Sub wmiEvent_OnObjectReady(ByVal objWbemObject As WbemScripting.ISWbemObject, ByVal objWbemAsyncContext As WbemScripting.ISWbemNamedValueSet)
Eject ("\\.\" & objWbemObject.Properties_.Item("TargetInstance").Value.Properties_.Item("Caption").Value)
End Sub
2、这个方法网上资料很多，缺点也不少。修改、监测和U盘有关的注册表项，如果注册表项被改动就自动改回原值，起到禁用的效果。也可以把代码中的注册表项换成其他你需要监测的注册表项。
Public WithEvents wmiEvent As SWbemSink
Const HKEY_LOCAL_MACHINE = &H80000002
Dim wmiLocator As New SWbemLocator
Dim wmiServices As SWbemServices
Dim wMIObject As SWbemObject
Private Sub CommandButton1_Click()
Set wmiEvent = New SWbemSink
Set wmiServices = wmiLocator.ConnectServer(".", "root\default")
Set wMIObject = wmiServices.Get("StdRegProv")
wMIObject.setDWORDValue HKEY_LOCAL_MACHINE, _
"SYSTEM\CurrentControlSet\services\USBSTOR\", "Start", 4
wmiServices.ExecNotificationQueryAsync wmiEvent, "SELECT * FROM RegistryKeyChangeEvent WITHIN 1" & _
"WHERE Hive='HKEY_LOCAL_MACHINE' AND KeyPath='SYSTEM\\CurrentControlSet\\services\\USBSTOR'"
End Sub
Private Sub CommandButton2_Click()
If Not wmiEvent Is Nothing Then
wmiEvent.Cancel
Set wmiEvent = Nothing
wMIObject.setDWORDValue HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\services\USBSTOR\", "Start", 3
Set wMIObject = Nothing
Set wmiServices = Nothing
Set wmiLocator = Nothing
End If
End Sub
Private Sub wmiEvent_OnObjectReady(ByVal objWbemObject As WbemScripting.ISWbemObject, ByVal objWbemAsyncContext As WbemScripting.ISWbemNamedValueSet)
Dim sValue
wMIObject.GetDWORDValue HKEY_LOCAL_MACHINE, _
"SYSTEM\CurrentControlSet\services\USBSTOR\", "Start", sValue
If sValue <> 4 Then
wMIObject.setDWORDValue HKEY_LOCAL_MACHINE, _
"SYSTEM\CurrentControlSet\services\USBSTOR\", "Start", 4
MsgBox "注册表:HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\services\USBSTOR\" & vbCrLf & _
"下的键“Start”的值被修改！但是该键值已经强制重新设为4，即禁止U盘。"
End If
End Sub
|
评分
-
2
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2013-6-7 21:26
