Открыть/закрыть CD-Rom одной кнопкой

[Pr0[)!9Y]

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 Sub OpenCloseDoor(strDriveLetter As String, blnDoOpen As Boolean)
Dim AliasName$, strOpenClose$
strOpenClose = IIf(blnDoOpen, "Open", "Closed")
AliasName = "Laufwerk" & strDriveLetter
mciSendString "Open " & strDriveLetter & ": Alias " & AliasName & " Type CDAudio", 0, 0, 0
mciSendString "Set " & AliasName & " Door " & strOpenClose, 0, 0, 0
End Sub
 
Private Sub Command1_Click()
Dim t As Long
t = Timer
OpenCloseDoor "f:\", True
If Timer - t < 1 Then OpenCloseDoor "f:\", False
End Sub

[SCINER]

Вариант Spawn™Production®
Расположите на форме 1 кнопку.

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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub OpenCloseDoor(strDriveLetter As String, blnDoOpen As Boolean)
Dim AliasName$, strOpenClose$
strOpenClose = IIf(blnDoOpen, "Open", "Closed")
AliasName = "Laufwerk" & strDriveLetter
mciSendString "Open " & strDriveLetter & ": Alias " & AliasName & " Type CDAudio", 0, 0, 0
mciSendString "Set " & AliasName & " Door " & strOpenClose, 0, 0, 0
End Sub
 
Private Sub d_Click()
Dim t As Long
t = Timer
OpenCloseDoor "f:\", True
Sleep 100
Debug.Print Timer - t
If Timer - t < 1 Then
OpenCloseDoor "f:\", False
Else
OpenCloseDoor "f:\", True
End If
End Sub
 
Private Sub Command1_Click()
d_Click
End Sub

Вариант maxim84_

Option Explicit
 
Const SHGFI_ICONLOCATION = &H1000
Const MB_ICONASTERISK = &H40&
Const MB_ICONEXCLAMATION = &H30&
Const MAX_PATH = 260
 
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineA" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
 
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const EndPath = ":\"
Dim Key As Long
 
Private Sub OpenCloseDoor(strDriveLetter As String, blnDoOpen As Boolean)
  Dim AliasName$, strOpenClose$
  strOpenClose = IIf(blnDoOpen, "Open", "Closed")
  AliasName = "Laufwerk" & strDriveLetter
  mciSendString "Open " & strDriveLetter & ": Alias " & AliasName & " Type CDAudio", 0, 0, 0
  mciSendString "Set " & AliasName & " Door " & strOpenClose, 0, 0, 0
End Sub
 
Private Sub Command1_Click()
 d_Click
End Sub
Private Sub d_Click()
 Dim t As Long
  t = Timer
  OpenCloseDoor Combo1.List(Combo1.ListIndex) & EndPath, True
  Sleep 100
  If Timer - t < 1 Then
   OpenCloseDoor Combo1.List(Combo1.ListIndex) & EndPath, False
  Else
   OpenCloseDoor Combo1.List(Combo1.ListIndex) & EndPath, True
  End If
End Sub
 
Private Sub Form_Load()
    Dim LDs As Long, Cnt As Long, sDrives As String
    LDs = GetLogicalDrives
    For Cnt = 0 To 25
        If (LDs And 2 ^ Cnt) <> 0 Then
            If GetDriveType(Trim$(sDrives & Chr$(65 + Cnt) & EndPath)) = 5 Then
             Combo1.AddItem sDrives & Chr$(65 + Cnt)
            End If
        End If
    Next Cnt
    Combo1.ListIndex = 0
End Sub