S' amuser avec les lecteurs cd (bug corrigé)

Télécharger le projet
Commenter

Description

Je m' emmerdait, cet aprem, alors j' ai bricolé un prog qui ouvre et ferme les lecteurs CDs

Source / Exemple : 


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

Conclusion :


J' ai malhereusement qu' un seul lecteur CD, je n' ai donc pas vraiment pu l' essayer, je demenderait alrs à eux qui en ont plusieurs de me faire part de vos commentaires.


J' ai un peu modifié le code: cette sub peut fermer séparément chaque lecteur. Elle devrait mieux marcher.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (SuperClic)