• Home
 · 
• Miscellaneous
 · 
• This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters -

This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters -

This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters - then assigns buttons to open or close the

Rate This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters -

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'The functions that find the CD-ROM letters and
'Opens and shuts the doors, I found somewhere on the net.

'place a button onto a form - call it CDBUTTON,
'copy and paste the button
'Answer yes to creating an array of the button.
'Delete one of these buttons - leave the CDBUTTON(1)
'Paste the code in to the declarations section
'Thats it - Enjoy

'Any problems - email [email protected]

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const DRIVE_CDROM = 5

'I found this code somewhere on the net - It's very useful
Public Sub cdDriveDoor(OpenDoor As Boolean, Optional DriveLetter As String = "")

Dim mssg As String * 255 'makes a string with 255 blank spaces
Dim DriveType As Long

    If DriveLetter <> "" Then
    'make sure the drive entered is a cd drive
    DriveType = GetDriveType(DriveLetter)
        If DriveType <> DRIVE_CDROM Then
            MsgBox DriveLetter & " is not a cd-rom drive", vbOKOnly + vbCritical, "Error"
            Exit Sub
        End If
        
        If OpenDoor = True Then 'open the drive door
            'open the drive as a cdaudio device
            mciSendString "Open " & DriveLetter & " Type cdaudio Alias cd", mssg, 255, 0
            'open the door
            mciSendString "set cd door open", 0&, 0, 0
            'close the drive as a cdaudio device
            mciSendString "close cd", 0&, 0, 0
        Else 'close the drive door
            'open the drive as a cdaudio device
            mciSendString "Open " & DriveLetter & " Type cdaudio alias cd", mssg, 255, 0
            'close the door
            mciSendString "set cd door closed", 0&, 0, 0
            'close the drive as a cdaudio device
            mciSendString "close cd", 0&, 0, 0
        End If
        
    Else 'no driveletter entered
        If OpenDoor = True Then
            'open the door of the default cdaudio device (first cd drive)
            mciSendString "set cdaudio door open", 0&, 0, 0
        Else
            'close the door of default device
            mciSendString "set cdaudio door closed", 0&, 0, 0
        End If
    End If
End Sub

'Again I found this function
Function FINDCDLETTERS()
Dim tmp As Integer
Dim tmpStr As String
Dim Drives As String
Dim CDsCount As Integer
Dim CDsLetters As String
Const DRIVE_CDROM = 5

'init Drives to 255 spaces
Drives = Space(255)
'get drives, Drives var will look like
'   A:\<NULL>C:\<NULL>D:\<NULL>E:\<NULL><NULL>
'ret& is the new length of Drives
ret& = GetLogicalDriveStrings(Len(Drives), Drives)
For tmp = 1 To ret& Step 4
 'get a drive root directory (like "C:\")
 tmpStr = Mid(Drives, tmp, 3)
 'if drive is a CD
 If GetDriveType(tmpStr) = DRIVE_CDROM Then
  CDsCount = CDsCount + 1
  CDsLetters = CDsLetters & Left(tmpStr, 1) '& " "
 End If
Next tmp
FINDCDLETTERS = CDsLetters
End Function

Private Sub CDBUTTON_Click(Index As Integer)
'If button changes its caption to display either oper of closed
If InStr(1, CDBUTTON(Index).Caption, "Open", vbTextCompare) <> 0 Then
    cdDriveDoor True, Right(CDBUTTON(Index).Caption, 1) & ":\"
    CDBUTTON(Index).Caption = "Close " & Right(CDBUTTON(Index).Caption, 1)
Else
    cdDriveDoor False, Right(CDBUTTON(Index).Caption, 1) & ":\"
    CDBUTTON(Index).Caption = "Open " & Right(CDBUTTON(Index).Caption, 1)
End If

End Sub

Private Sub Form_Load()
'on loading the function finds all CD-ROMS and makes buttons for each.
strcd = FINDCDLETTERS
If Len(strcd) = 0 Then Exit Sub

CDBUTTON(1).Caption = "Open " & Mid(strcd, 1, 1)

For X = 2 To Len(strcd)
    Load CDBUTTON(X)
    CDBUTTON(X).Visible = True
    CDBUTTON(X).Top = CDBUTTON(X - 1).Top + CDBUTTON(X - 1).Height + 100
    CDBUTTON(X).Left = CDBUTTON(X - 1).Left
    CDBUTTON(X).Width = CDBUTTON(X - 1).Width
    CDBUTTON(X).Height = CDBUTTON(X - 1).Height
    CDBUTTON(X).Caption = "Open " & Mid(strcd, X, 1)
Next

'resizes the form to suit all of the buttons.
X = X - 1
Me.Height = CDBUTTON(X).Top + CDBUTTON(X).Height + 500
Me.Width = CDBUTTON(X).Width + CDBUTTON(X).Left

End Sub