S' AMUSER AVEC LES LECTEURS CD (BUG CORRIGÉ)

Private Declare Function GetVersion Lib "kernel32" () 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
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
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Const INVALID_HANDLE_VALUE = -1
Const OPEN_EXISTING = 3
Const FILE_FLAG_DELETE_ON_CLOSE = 67108864
Const FILE_FLAG_WRITE_THROUGH = &H80000000
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
Const IOCTL_STORAGE_EJECT_MEDIA = 2967560
Const IOCTL_STORAGE_LOAD_MEDIA = 2967564
Const VWIN32_DIOC_DOS_IOCTL = 1
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2
Const CREATE_NEW = 1
Const CREATE_ALWAYS = 2
Const OPEN_ALWAYS = 4
Const TRUNCATE_EXISTING = 5

Private Type DIOC_REGISTERS
  reg_EBX As Long
  reg_EDX As Long
  reg_ECX As Long
  reg_EAX As Long
  reg_EDI As Long
  reg_ESI As Long
  reg_Flags As Long
End Type

Public Sub lancement()
Dim Lecteur(1000), LecteurInv(1000), LecteurPair(500), LecteurImpair(500) As String
Set fso = CreateObject("Scripting.Filesystemobject")
Set ListeLecteurs = fso.drives
i = 0

For Each ListeEntree In ListeLecteurs
    If ListeEntree.drivetype = 4 Then Lecteur(i) = ListeEntree: i = i + 1
Next
NbLecteurs = i

' retrie dans l' ordre décroissant
boucle = 0
Do
    LecteurInv(boucle) = Lecteur(NbLecteurs - 1 - boucle)
    boucle = boucle + 1
Loop Until boucle = NbLecteurs

'trie pair/impair
NP = 0
NiP = 0
boucle = 0
Do
    If boucle / 2 = Int(boucle / 2) Then
        LecteurPair(boucle) = Lecteur(boucle)
        NP = NP + 1
    Else
        LecteurPair(boucle) = Lecteur(boucle)
        NiP = NiP + 1
    End If
    boucle = boucle + 1
Loop Until boucle = NbLecteurs


'trie impair


'*****  départ
Do
DoEvents

' ouvre dans l'ordre
For boucle = 1 To NbLecteurs
    Pause (0.5 / NbLecteurs)
    DoEvents
    ouvrirlecteur (Lecteur(boucle - 1))
Next
Pause (1)
' ferme tout
For boucle = 1 To NbLecteurs
    FermerLecteur (Lecteur(boucle - 1))
Next
Pause (2)

' ouvre dans le désordre
For boucle = 1 To NbLecteurs
    Pause (0.5 / NbLecteurs)
    DoEvents
    ouvrirlecteur (LecteurInv(boucle - 1))
Next
Pause (1)
' ferme tout
For boucle = 1 To NbLecteurs
    FermerLecteur (Lecteur(boucle - 1))
Next

Pause (2)



'Pair puis impairs
For boucle = 1 To NP
    ouvrirlecteur (LecteurPair(boucle - 1))
Next
Pause (0.5)
For boucle = 1 To NiP
    ouvrirlecteur (LecteurImpair(boucle - 1))
Next
Pause (1)
For boucle = 1 To NP
    FermerLecteur (LecteurPair(boucle - 1))
Next
Pause (0.5)
For boucle = 1 To NiP
    FermerLecteur (LecteurImpair(boucle - 1))
Next

Pause (2)


'Impair puis Pairs
For boucle = 1 To NiP
    ouvrirlecteur (LecteurImpair(boucle - 1))
Next
Pause (0.5)
For boucle = 1 To NP
    ouvrirlecteur (LecteurPair(boucle - 1))
Next
Pause (1)
For boucle = 1 To NiP
    FermerLecteur (LecteurImpair(boucle - 1))
Next
Pause (0.5)
For boucle = 1 To NP
    FermerLecteur (LecteurPair(boucle - 1))
Next



Pause (2)

DoEvents
Pause (1.5)
Loop
End Sub
Sub ouvrirlecteur(Lecteur)

Dim hDrive As Long, DummyReturnedBytes As Long
Dim RawStuff As DIOC_REGISTERS
  If Len(Lecteur) Then 'Si une réponse
    If GetVersion >= 0 Then 'marche si Windows NT/2000 ou XP
      hDrive = CreateFile("\\.\" & Lecteur, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, OPEN_EXISTING, 0, 0)
      If hDrive <> INVALID_HANDLE_VALUE Then
        'Ejecte CD!
        Call DeviceIoControl(hDrive, IOCTL_STORAGE_EJECT_MEDIA, 0, 0, 0, 0, DummyReturnedBytes, ByVal 0)
        Call CloseHandle(hDrive)  'Fin
      End If
    Else  'marche si Windows 9x ou Me
      hDrive = CreateFile("\\.\VWIN32", 0, 0, ByVal 0, 0, FILE_FLAG_DELETE_ON_CLOSE, 0)
      If hDrive <> INVALID_HANDLE_VALUE Then
        RawStuff.reg_EAX = &H440D   'Fonction a utiliser    ???? !!! ????
        RawStuff.reg_EBX = Asc(Lecteur) - Asc("A") + 1 'Ouvre le lecteur
        RawStuff.reg_ECX = &H49 Or &H800
        'Ouverture
        Call DeviceIoControl(hDrive, VWIN32_DIOC_DOS_IOCTL, RawStuff, LenB(RawStuff), RawStuff, LenB(RawStuff), DummyReturnedBytes, ByVal 0)
        Call CloseHandle(hDrive)  'Fin
      End If
    End If
  End If

End Sub





Public Sub FermerLecteur(Lecteur)
Dim hDisk As Long
Dim dwRc As Long
Dim sDisk As String


LettreLecteur = Left(Lecteur, Len(Lecteur) - 1)
   
' Crée le nom du disque
sDisk = "\\.\" & UCase(Mid(LettreLecteur, 1, 1)) & ":"
    
'prépare le "handle"
hDisk = CreateFile(sDisk, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or _
                    FILE_SHARE_WRITE, ByVal CLng(0), OPEN_EXISTING, FILE_FLAG_WRITE_THROUGH, _
                    ByVal CLng(0))
If hDisk = -1 Then Exit Sub 'erreur
    
'Vide la memoire cache
FlushFileBuffers (hDisk)
 
'Rentre le lecteur
If DeviceIoControl(hDisk, IOCTL_STORAGE_LOAD_MEDIA, _
                    ByVal CLng(0), 0, ByVal CLng(0), 0, _
                    dwRc, ByVal CLng(0)) = 0 Then
End If
    'fini
    CloseHandle (hDisk)
End Sub


Sub Pause(temps) 'en secondes
t = Timer
Do
    DoEvents
Loop Until Timer >= t + temps
End Sub