Åpne og lukke CD/DVD skuffen

Med makroene nedenfor kan man åpne og lukke systemets standard CD/DVD skuff.

Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
    ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
    ByVal hwndCallback As Long)

Sub OpenDefaultDiscTray()
    mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub

Sub CloseDefaultDiscTray()
    mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub

Man kan benytte makroen nedenfor til å åpne en spesifikk CD/DVD skuff dersom man kjenner stasjonsbokstaven.
Man trenger eventuelt et tredjepartsverktøy for å lukke skuffen med kode.

Sub OpenDiscTray(strDriveLetter As String)
' this will open the CD/DVD tray for the given drive letter
' e.g.: OpenDiscTray "F"
Dim Shell As Object, MyComputer As Object
    Set Shell = CreateObject("Shell.Application")
    Set MyComputer = Shell.Namespace(17)
    On Error Resume Next
    MyComputer.ParseName(strDriveLetter & ":\").InvokeVerb ("e&ject")
    On Error GoTo 0
    Set MyComputer = Nothing
    Set Shell = Nothing
End Sub

Man kan benytte makroen nedenfor til å sjekke om en stasjon er klar, f.eks. når en plate er satt inn i en CD/DVD stasjon.

Function DriveIsReady(strDriveLetter As String) As Boolean
' returns True if a drive is ready, e.g. a disc is present in a CD/DVD drive
Dim fso As Scripting.FileSystemObject, drv As Scripting.Drive
Dim Shell As Object, MyComputer As Object
    Set fso = New FileSystemObject
    On Error Resume Next
    Set drv = fso.GetDrive(strDriveLetter)
    On Error GoTo 0
    If Not drv Is Nothing Then
        DriveIsReady = drv.IsReady
        Set drv = Nothing
    End If
    Set fso = Nothing
End Function

Her er en eksempelmakro som benytter de siste to eksempelmakroene:

Sub TestDiscTrays()
Dim i As Integer
    OpenDiscTray "G"
    i = MsgBox("Click OK when you have inserted a new disc.", vbOKCancel)
    If i = vbCancel Then Exit Sub ' user aborted
    
    If Not DriveIsReady("G") Then
        MsgBox "Disc not inserted, aborting...", vbExclamation
        Exit Sub
    End If
    
    ' continue your tasks here, e.g. like this
    'FileCopy "G:\somefile.txt", "C:\"
    
End Sub

Dokumentet er sist oppdatert 2005-09-26 13:02:56 Utskriftsvennlig versjon