Attribute VB_Name = "DriveUtilities"
Option Explicit

Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
    wServicePackMajor   As Integer
    wServicePackMinor   As Integer
    wSuiteMask          As Integer
    bProductType        As Byte
    bReserved           As Byte
End Type

Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type


Private Type WNDCLASS
    style As Long
    lpfnwndproc As Long
    cbClsextra As Long
    cbWndExtra2 As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
End Type

Private Type DEV_BROADCAST_HDR
    dbch_size As Long
    dbch_devicetype As Long
    dbch_reserved As Long
End Type

Private Type DEV_BROADCAST_VOLUME
    dbcv_size As Long
    dbcv_devicetype As Long
    dbcv_reserved As Long
    dbcv_unitmask As Long
    dbcv_flags As Integer
End Type

Private Type DEVICE_MEDIA_INFO
    Cylinders As Double
    MediaType As Long
    TracksPerCylinder As Long
    SectorsPerTrack As Long
    BytesPerSector As Long
    NumberMediaSides As Long
    MediaCharacteristics As Long
End Type

Private Type GET_MEDIA_TYPES
    DeviceType As Long
    MediaInfoCount As Long
    MediaInfo(10) As DEVICE_MEDIA_INFO
End Type

Private Type OVERLAPPED
    ternal As Long
    ternalHigh As Long
    offset As Long
    OffsetHigh As Long
    hEvent As Long
End Type

Private Type PREVENT_MEDIA_REMOVAL
    PreventMediaRemoval As Long
End Type

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function UnregisterClass Lib "user32.dll" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RegisterClass Lib "user32.dll" Alias "RegisterClassA" (ByRef Class As WNDCLASS) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_DEVICECHANGE As Long = &H219
Private Const DBT_DEVICEARRIVAL As Long = &H8000&
Private Const DBT_DEVICEREMOVECOMPLETE As Long = &H8004&
Private Const DBT_DEVTYP_VOLUME As Long = &H2
Private Const DBTF_MEDIA As Long = &H1

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


Private 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

'Permet de controler le périphérie
Private 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

'Sert à savoir le type de "drive"
Private Declare Function GetDriveType Lib "kernel32" Alias _
"GetDriveTypeA" (ByVal nDrive As String) As Long

'sert à énumerer tous les lecteurs
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

'Sert à soutirer la version de windows
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" _
(ByRef lpVersionInformation As OSVERSIONINFOEX) As Long

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long

Private Const DRIVE_REMOVABLE As Long = 2 '<------------------Flash disk + Disquette
Private Const DRIVE_FIXED As Long = 3 '<--------Disk dures
Private Const DRIVE_REMOTE As Long = 4
'private Const DRIVE_CDROM = 5 '<----------CD
Private Const DRIVE_RAMDISK As Long = 6
Private Const DRIVE_CDROM As Long = 5

Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const FILE_DEVICE_CD_ROM As Long = &H2
Private Const FILE_DEVICE_DVD As Long = &H33
Private Const FILE_FLAG_OVERLAPPED As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const GENERIC_READ As Long = &H80000000
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const IOCTL_STORAGE_EJECT_MEDIA As Long = &H2D4808
Private Const IOCTL_STORAGE_GET_MEDIA_TYPES_EX As Long = &H2D0C04
Private Const IOCTL_STORAGE_LOAD_MEDIA As Long = &H2D480C
Private Const IOCTL_STORAGE_MEDIA_REMOVAL As Long = &H2D4804
Private Const LB_ITEMFROMPOINT As Long = &H1A9
Private Const OPEN_EXISTING As Long = 3

Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Public Enum MYVOLUMEINFO
    VI_VolumeName
    VI_VolumeSerialNumber
    VI_MaximumComponentLength
    VI_FileSystemFlag
    VI_FileSystemName
    VI_FileSystemSize
End Enum

'Pour le Vérouillage du lecteur
Public Function LockDrive(ByRef vsDriveLetter As String, Optional ByVal vbAllow As Boolean = False) As Long
    Dim lDrive As Long
    Dim lLength As Long
    Dim lPMR As PREVENT_MEDIA_REMOVAL
    '# On créé un handle vers le lecteur
    lDrive = CreateFile("\\.\" & vsDriveLetter & ":", GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If lDrive <> INVALID_HANDLE_VALUE Then
        lPMR.PreventMediaRemoval = Abs(Not vbAllow)
        '# On appelle la fonction de lock/unlock
        LockDrive = DeviceIoControl(lDrive, IOCTL_STORAGE_MEDIA_REMOVAL, lPMR, LenB(lPMR), 0, 0, lLength, ByVal 0&)
        '# On libère le handle
        CloseHandle lDrive
    End If
End Function

Public Sub OpenCloseMedia(ByRef vsDriveLetter As String, Optional ByVal vbOpen As Boolean = True, Optional ByVal vbAsynchrounously As Boolean = True)
    Dim lDrive As Long
    Dim lLength As Long
    Dim lControlCode As Long
    Dim lOL As OVERLAPPED
    '# On créé un handle vers le lecteur
    If vbAsynchrounously Then
        lDrive = CreateFile("\\.\" & vsDriveLetter & ":", GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
    Else
        lDrive = CreateFile("\\.\" & vsDriveLetter & ":", GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    End If
        
    If lDrive <> INVALID_HANDLE_VALUE Then
        '# On appelle la fonction d'ouverture/fermeture
        If vbOpen Then
            lControlCode = IOCTL_STORAGE_EJECT_MEDIA '<-----Ejecter
        Else
            lControlCode = IOCTL_STORAGE_LOAD_MEDIA '<------Fermer
        End If
        'le controleur
        DeviceIoControl lDrive, lControlCode, ByVal 0&, 0, 0, 0, lLength, lOL
        
        '# On libère le handle
        CloseHandle lDrive
    End If
End Sub

Public Function IsDVD(ByRef vsDriveLetter As String) As Boolean
Dim lDrive As Long
Dim lLength As Long
Dim lGMT As GET_MEDIA_TYPES
        
    '# On créé un handle vers le lecteur
    lDrive = CreateFile("\\.\" & vsDriveLetter & ":", GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If lDrive <> INVALID_HANDLE_VALUE Then
        DeviceIoControl lDrive, IOCTL_STORAGE_GET_MEDIA_TYPES_EX, vbNullString, 0, lGMT, LenB(lGMT), lLength, ByVal 0&
        IsDVD = (lGMT.DeviceType = FILE_DEVICE_DVD)

        '# On libère le handle
        CloseHandle lDrive
    End If
End Function


'#################################################################
'Définit si c'est un lecteur CD
'#################################################################
Public Function IsCDDrive(ByRef vsDriveLetter As String) As Boolean
Dim lDrive As Long
Dim lLength As Long
Dim lGMT As GET_MEDIA_TYPES
        
    '# On créé un handle vers le lecteur
    lDrive = CreateFile("\\.\" & vsDriveLetter & ":", GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If lDrive <> INVALID_HANDLE_VALUE Then
        DeviceIoControl lDrive, IOCTL_STORAGE_GET_MEDIA_TYPES_EX, vbNullString, 0, lGMT, LenB(lGMT), lLength, ByVal 0&
        IsCDDrive = (lGMT.DeviceType = FILE_DEVICE_DVD) Or (lGMT.DeviceType = FILE_DEVICE_CD_ROM)

        '# On libère le handle
        CloseHandle lDrive
    End If
End Function

Public Function GetAddress(ByVal Add As Long) As Long
    GetAddress = Add
End Function

Public Function GetObjectFromRef(ByVal Ref As Long) As IUnknown
Dim Obj As IUnknown
    CopyMemory Obj, Ref, 4
    Set GetObjectFromRef = Obj
    CopyMemory Obj, 0&, 4
End Function

Public Sub ReleaseObject(ByVal ObjPtr As Long)
    CopyMemory ObjPtr, 0&, 4
End Sub

Public Function GetVolumeInfo(ByVal strDrive As String, sReturn As MYVOLUMEINFO) As String
    Dim lSerialNum As Long
    Dim Res As Long
    Dim sVolumeName As String
    Dim lMaxComponentLen As Long
    Dim lFileSystemFlag As Long
    Dim sFileSystemName As String
    'initialise the strings
    sVolumeName = String$(255, Chr$(0))
    sFileSystemName = String$(255, Chr$(0))
    
    If Len(strDrive) Then
        If InStr(strDrive, "\\") = 1 Then
            'Make sure we end in backslash for UNC
            If Right$(strDrive, 1) <> "\" Then
                strDrive = strDrive & "\"
            End If
        Else
            'If not UNC take first letter as drive
            strDrive = Left$(strDrive, 1) & ":\"
        End If
    Else
        'Use current drive
        strDrive = vbNullString
    End If
    
    'call the API function
    Res = GetVolumeInformation(strDrive, sVolumeName, Len(sVolumeName), lSerialNum, lMaxComponentLen, lFileSystemFlag, sFileSystemName, Len(sFileSystemName))
    Select Case sReturn
        Case VI_FileSystemFlag
            GetVolumeInfo = lFileSystemFlag
        Case VI_FileSystemName
            GetVolumeInfo = sFileSystemName
        Case VI_FileSystemSize
            GetVolumeInfo = Len(sFileSystemName)
        Case VI_MaximumComponentLength
            GetVolumeInfo = lMaxComponentLen
        Case VI_VolumeName
            GetVolumeInfo = sVolumeName
        Case VI_VolumeSerialNumber
            GetVolumeInfo = lSerialNum
    End Select
End Function

Public Function GetSerialNumber(ByVal sDrive As String) As Long

If Len(sDrive) Then
  If InStr(sDrive, "\\") = 1 Then
    'Make sure we end in backslash for UNC
    If Right$(sDrive, 1) <> "\" Then
      sDrive = sDrive & "\"
    End If
  Else
  'If not UNC take first letter as drive
  sDrive = Left$(sDrive, 1) & ":\"
  End If
Else
  'Use current drive
  sDrive = vbNullString
End If

Call GetVolumeInformation(sDrive, vbNullString, 0, GetSerialNumber, ByVal 0&, _
      ByVal 0&, vbNullString, 0)
End Function

