How to determine when a removable drive has been added

[FaneDuru]

I have an Excel VBA application which sometimes needs to catch the event of removable drives adding (inserting in USB).
I found in MSDN a monitoring WMI script sample able to trigger the adding or removing event:

strComputer = "."	
Set objWMIService = GetObject("winmgmts:" _	
    & "{impersonationLevel=impersonate}!\\" _	
    & strComputer & "\root\cimv2")	
Set colMonitoredEvents = objWMIService. _	
    ExecNotificationQuery( _	
        "Select * from Win32_VolumeChangeEvent")	
Do	
    Set objLatestEvent = colMonitoredEvents.NextEvent	
    Wscript.Echo objLatestEvent.DriveName	
    Wscript.Echo objLatestEvent.EventType	
    Wscript.Echo objLatestEvent.Time_Created	
Loop

Trying to adapt it to VBA works only with Excel freezing (because of Do Loop cycle). I found code samples for VB.Net and VB6 but not for VBA.
Can anybody help on this issue?
Thanks in advance!

 

[FaneDuru]

It looks that the line:

Set objLatestEvent = colMonitoredEvents.NextEvent

makes Excel freeze if an event did not occur yet...
I used Timer in a VBA module and until an event occurs I can play with Excel. In the moment of reaching the above line Excel 'waits' for an event to come
Here is the code (in a module):

Public Declare Function SetTimer Lib "user32" ( _
                    ByVal HWnd As Long, ByVal nIDEvent As Long, _
                    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
                    ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
                    
Private TimerID As Long, TimerSeconds As Long
Private objWMIService As Object, colMonitoredEvents As Variant

Sub StartTimer()
    TimerSeconds = 5 ' how often timer works (sec).
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000, AddressOf Timer_Proc)
End Sub
Sub StopTimer()
       On Error Resume Next
       KillTimer 0, TimerID
End Sub
Sub Timer_Proc(ByVal HWnd As Long, ByVal uMsg As Long, _
            ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim objLatestEvent As Variant
          
      On Error Resume Next
      Set objLatestEvent = colMonitoredEvents.NextEvent()
      If Not objLatestEvent Is Nothing Then
            Debug.Print objLatestEvent.DriveName, IIf(objLatestEvent.EventType = 2, _
                                    "Added", IIf(objLatestEvent.EventType = 3, _
                                                    "Removed", "Something else"))
        'Debug.Print objLatestEvent.EventType
        'Debug.Print objLatestEvent.Time_Created
            StopTimer
      End If
      On Error GoTo 0
End Sub

Sub Remov_Media_Monitoring()
 strComputer = "."
 Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" _
                                                    & strComputer & "\root\cimv2")
 Set colMonitoredEvents = objWMIService.ExecNotificationQuery( _
                            "Select * from Win32_VolumeChangeEvent")
 StartTimer
End Sub

I tried On Error Resume Next, but it is not any error. It just waits for an event and Excel freezes until that event occurs...
I also tried IsEmpty, IsNull, IsArray for 'colMonitoredEvents' (event Count declaring it like Object) in order to avoid the incriminated line of code but I could not find any solution...

 

[FaneDuru]

I almost solved the problem in this way:

Sub test_Check_Drive_Insertion()
Dim x As String, Z As String
Z = ThisWorkbook.Name

x = "Set objWMIService = GetObject(""winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"")" & vbCrLf
x = x & "Set colMonitoredEvents = objWMIService.ExecNotificationQuery(""Select * from Win32_VolumeChangeEvent"")" & vbCrLf
x = x & "Do" & vbCrLf
x = x & "    Set objLatestEvent = colMonitoredEvents.NextEvent" & vbCrLf
x = x & "    If objLatestEvent.DriveName <> """" And objLatestEvent.EventType = 2 Then" & vbCrLf
x = x & "        ControlatExcel objLatestEvent.DriveName" & vbCrLf
x = x & "        Exit Do" & vbCrLf
x = x & "    End If" & vbCrLf
x = x & "Loop" & vbCrLf
x = x & "Sub ControlatExcel(Drive)" & vbCrLf
x = x & "  Set ExcelDeschis = GetObject(,""Excel.application"")" & vbCrLf & _
"With ExcelDeschis" & vbCrLf & _
"  .Run " & Chr(34) & "'" & Z & "'!myProc""'" & ", Drive" & vbCrLf & _
"End With" & vbCrLf & _
"Set ExcelExistent = Nothing" & vbCrLf & _
"End Sub"

Cale = ThisWorkbook.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set VB = fso.OpenTextfile(Cale & "\Test.vbs", 2, True)
   VB.Write x
   VB.Close
Set Loc1 = fso.GetFile(Cale & "\Test.vbs")
Set shl = CreateObject("Shell.Application")
 shl.Open Loc1.Path
End Sub
Sub myProc(Optional Drivul As String)
 If Drivul = "" Then Drivul = "D:"
  MsgBox "Drive " & Chr(34) & Drivul & Chr(34) & ", has been inserted...", , "Called from VBScript"
End Sub

VBA writes the script code and launch it in execution. When an insertion of a drive is found the script looks for opened Excel session and call a procedure from the file where it has been borne.
The problem is that I am not able to pass the argument to the procedure. If you look at the script line where it 'Runs' procedure call it is a " ' " character transforming that part of the code in comment. I am able to just call the procedure, not to pass the argument. I know how to do that in VBA and I checked this piece of code:

Application.Run "My workbook - Stick USB.xlsm'!myProc", "H:"

Using the approach in the script code (without ' character) I could not pass the argument.
Can somebody help me in order to pass the argument from VBScript?
Thanks in advance!

 

[FaneDuru]

I figured it out but in a little stange manner...
This line of code:

"  .Run " & Chr(34) & "'" & Z & "'!myProc""" & ", Drive" & vbCrLf & _

has been replatec with this one:

"  .Run " & Chr(34) & "'" & Z & "'!myProc""," & " chr(34) & Drive & chr(34)" & vbCrLf & _

What is strange: It does not work using 'Drive' (="H:"). It works only with the equivalent of ""H:"" and returns ""H:"" to Excel procedure.
But I can clean the marginal quotes and use it. The script takes only 2.16 k of memory...