Private Declare Function GetLogicalDriveStrings _
  Lib "kernel32" Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
  ByVal lpBuffer As String) As Long
 
Private Declare Function GetDriveType Lib _
  "kernel32" Alias "GetDriveTypeA" _
  (ByVal nDrive As String) As Long
 
Private Declare Function GetVolumeInformation Lib "kernel32" _
        Alias "GetVolumeInformationA" (ByVal lpRootPathName _
        As String, ByVal lpVolumeNameBuffer As String, ByVal _
        nVolumeNameSize As Long, lpVolumeSerialNumber As Long, _
        lpMaximumComponentLength As Long, lpFileSystemFlags _
        As Long, ByVal lpFileSystemNameBuffer As String, ByVal _
        nFileSystemNameSize As Long) As Long
 
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
 
Private Sub CommandButton1_Click()
 
    Dim X As Long, AA As String, Result As Long
    Dim SerN As Long, PathL As Long, Flags As Long
    Dim XPC As Long, BPS As Long
    Dim FreeB As Double, FreeC As Long
    Dim TotB As Double, TotC As Long
    Dim VolN As String * 256
    Dim FileS As String * 256
 
    Dim sDrives As String
    ' Ermitteln ALLER WechsellaufwerkeLaufwerke
    sDrives = GetAllDrives(DRIVE_REMOVABLE)
 
    If Len(sDrives) > 0 Then
 
        For I = 1 To Len(sDrives)
 
            drv = Mid(sDrives, I, 1) & ":\"
 
            Result = GetVolumeInformation(drv, VolN, 256, SerN, _
                                    PathL, Flags, FileS, 256)
 
            If Result = 0 Then
                'fehler
 
            Else
                'Abfragen ob gefundene Laufwerksbezeichnung
                'der Bezeichnung des USB Sticks entspricht...
                'muss du an den namen deines USB sticks anpassen
                If Replace(VolN, Chr(0), "") = "UDISKPRO" Then
                    MsgBox "USB-Stick gefunden: " & drv
                    Exit Sub
                End If
            End If
        Next
 
    Else
 
        'kein Wechsellaufwerk vorhanden
 
    End If
 
End Sub
 
' Alle Laufwerke eines bestimmten Typs ermitteln
' z.B. CD-ROM Laufwerke
Function GetAllDrives(Optional ByVal DriveType As _
  Long = 0) As String
 
  Dim I As Integer
  Dim Result As Long
  Dim Drives() As String
  Dim Dummy As String
  Dim sDrives As String
 
  Dummy = Space(255)
  Result = GetLogicalDriveStrings(Len(Dummy), Dummy)
 
  Drives = Split(Dummy, Chr$(0))
  For I = 0 To UBound(Drives) - 1
    If GetDriveType(Drives(I)) = DriveType Or _
      DriveType = 0 Then
      sDrives = sDrives & Left$(Drives(I), 1)
    End If
  Next I
  GetAllDrives = sDrives
End Function