by Robert Payne (2 Submissions)
Category: Miscellaneous
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Sun 19th November 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
'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
No comments have been posted about This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters -. Why not be the first to post a comment about This code allows you to eject and close multiple CDROMS - It finds all of the CDROM drive letters -.