Public Const DRIVE_REMOVABLE As Long = 2
Public Const DRIVE_CDROM As Long = 5
Public Const INVALID_HANDLE_VALUE As Long = -1&
Public Const GENERIC_READ As Long = &H80000000
Public Const FILE_SHARE_READ As Long = &H1
Public Const FILE_SHARE_WRITE As Long = &H2
Public Const FILE_ANY_ACCESS As Long = &H0
Public Const FILE_READ_ACCESS  As Long = &H1
Public Const FILE_WRITE_ACCESS As Long = &H2
Public Const OPEN_EXISTING As Long = 3
Public Const IOCTL_STORAGE_MEDIA_REMOVAL As Long = &H2D4804

Public Type PREVENT_MEDIA_REMOVAL
   PreventMediaRemoval As Byte
End Type

Public Declare Function GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
  
Public Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal lpRootPathName As String) As Long
  
Public Declare Function DeviceIoControl Lib "kernel32" _
  (ByVal hDevice As Long, _
   ByVal dwIoControlCode As Long, _
   lpInBuffer As Any, _
   ByVal nInBufferSize As Long, _
   lpOutBuffer As Any, _
   ByVal nOutBufferSize As Long, _
   lpBytesReturned As Long, _
   lpOverlapped As Any) As Long

Public Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As Any, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long

Public Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Public Function DeviceLock(sDrive As String, fLock As Boolean) As Boolean

   Dim hDevice As Long
   Dim PMR As PREVENT_MEDIA_REMOVAL
   Dim bytesReturned As Long
   Dim success As Long
  
  'the drive letter has to be passed
  'to CreateFile without a trailing slash (ie 'G:')
   sDrive = UnQualifyPath(sDrive)
   
  'obtain a handle to the device 
  'using the correct device syntax
   hDevice = CreateFile("\\.\" & sDrive, _
                        GENERIC_READ, _
                        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                        ByVal 0&, _
                        OPEN_EXISTING, _
                        0&, 0&)

    
   If hDevice <> INVALID_HANDLE_VALUE Then

     'assign the fLock value to the
     'PREVENT_MEDIA_REMOVAL type
      PMR.PreventMediaRemoval = CByte(Abs(fLock))
  
     'If the operation succeeds,
     'DeviceIoControl returns a nonzero value
      success = DeviceIoControl(hDevice, _
                                IOCTL_STORAGE_MEDIA_REMOVAL, _
                                PMR, _
                                Len(PMR), _
                                ByVal 0&, _
                                0&, _
                                bytesReturned, _
                                ByVal 0&)
   
   End If
                       
   Call CloseHandle(hDevice)
   DeviceLock = success <> 0
  
End Function


Private Function UnQualifyPath(ByVal sPath As String) As String

  'removes any trailing slash from the path
   sPath = Trim$(sPath)
   
   If Right$(sPath, 1) = "\" Then
      UnQualifyPath = Left$(sPath, Len(sPath) - 1)
   Else
      UnQualifyPath = sPath
   End If
   
End Function

Option Explicit

Private Sub Form_Load()

  'load the removable drives and
  'disable the command buttons until
  'a drive is selected
   LoadAvailableDrives List1
   Command1(0).Enabled = False
   Command1(1).Enabled = False
   
End Sub


Private Sub List1_Click()

   Command1(0).Enabled = List1.ListIndex > -1
   Command1(1).Enabled = List1.ListIndex > -1
   
End Sub


Private Sub Command1_Click(Index As Integer)

   Dim fLock As Boolean
   Dim result As Boolean
   Dim sDrive As String
   
  'nothing to do if a drive's not selected
   If List1.ListIndex > -1 Then
   
     'get the selected drive
      sDrive = List1.List(List1.ListIndex)
   
     'DeviceIoControl requires the
     'IOCTL_STORAGE_MEDIA_REMOVAL
     'control code and a Boolean
     'indicating the lock state.
     'Passing False unlocks the device;
     'passing True locks it. This handily
     'corresponds to the 0/1 indices of
     'the Command button array.
      fLock = CBool(Index)
      result = DeviceLock(sDrive, fLock)
         
     'display result
      If result Then
      
         Select Case Index
            Case 0 
               Label1.Caption = "Device " & sDrive & " is unlocked."
            Case 1 
               Label1.Caption = "Device " & sDrive & " is locked."
         End Select
         
      Else
         Label1.Caption = "Call failed - perhaps no media in device."
      End If
   
   End If
   
End Sub


Private Sub LoadAvailableDrives(lst As ListBox)

   Dim lpBuffer As String
   Dim drvType As Long
   Dim currDrive As String

  'get list of available drives
   lpBuffer = GetDriveString()

  'Separate the drive strings
  'and add to the combo. StripNulls
  'will continually shorten the
  'string. Loop until a single
  'remaining terminating null is
  'encountered.
   Do Until lpBuffer = Chr(0)
  
     'strip off one drive item
     'and check for removable (or CD) status,
     'and add to the combo
      currDrive = StripNulls(lpBuffer)
      drvType = GetDriveType(currDrive)
   
      If (drvType = DRIVE_CDROM) Or _
         (drvType = DRIVE_REMOVABLE) Then
      
         lst.AddItem currDrive
      
      End If
    
   Loop
  
End Sub


Private Function StripNulls(startstr As String) As String

 'Take a string separated by chr$(0)
 'and split off 1 item, shortening the
 'string so next item is ready for removal.
  Dim pos As Long

  pos = InStr(startstr, Chr$(0))
  
  If pos Then
      
      StripNulls = Mid$(startstr, 1, pos - 1)
      startstr = Mid$(startstr, pos + 1, Len(startstr))
    
  End If

End Function


Private Function GetDriveString() As String

  'returns of available drives each
  'separated by a null
   Dim sBuffer As String
   
  'possible 26 drives, three characters each 
  'plus null, plus trailing null
   sBuffer = Space$((26 * 4)+ 1)
  
  If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then

     'trim string but do not
     'remove trailing null
      GetDriveString = Trim$(sBuffer)
      
   End If

End Function