Open and close the CD/DVD tray

 2005-09-26    Other    0    55

With the macros below you are able to open and close the default CD/DVD tray.

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
You can use the macro below to open a specific CD/DVD tray if you know the drive letter.
You will need a third party tool if you want to close the tray by code.

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
You can use the macro below to determine if a drive is ready, e.g. when a disc is present in a CD/DVD drive.

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
Here is an example macro that uses the last two example macros:

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