Option Explicit
 
Private Declare Function DeviceIoControl Lib "kernel32" ( _
    ByVal hDevice As Long, ByVal dwIoControlCode As Long, _
    ByRef lpInBuffer As Any, ByVal nInBufferSize As Long, _
    ByRef lpOutBuffer As Any, ByVal nOutBufferSize As Long, _
    ByRef lpBytesReturned As Long, ByVal lpOverlapped As Long _
) As Long
 
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
 
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long
 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" ( _
    lpVersionInformation As OSVERSIONINFOEX _
) As Long
 
Public Type DrvInfo
    open        As Boolean
    diskpresent As Boolean
End Type
 
Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize             As Long
    dwMajorVersion                  As Long
    dwMinorVersion                  As Long
    dwBuildNumber                   As Long
    dwPlatformId                    As Long
    szCSDVersion                    As String * 128
End Type
 
Private Type SPTD
    Length                          As Integer
    ScsiStatus                      As Byte
    PathId                          As Byte
    TargetID                        As Byte
    LUN                             As Byte
    CdbLength                       As Byte
    SenseInfoLength                 As Byte
    DataIn                          As Byte
    DataTransferLength              As Long
    TimeOutValue                    As Long
    DataBuffer                      As Long
    SenseInfoOffset                 As Long
    cdb(15)                         As Byte
    Fill(2)                         As Byte
End Type
 
Private Enum SPTIDirection
    SCSI_IOCTL_DATA_OUT = 0
    SCSI_IOCTL_DATA_IN = 1
End Enum
 
Private Const FILE_READ_ACCESS      As Long = &H1&
Private Const FILE_WRITE_ACCESS     As Long = &H2&
 
Private Const INVALID_HANDLE_VALUE  As Long = -1&
Private Const OPEN_EXISTING         As Long = &H3&
Private Const GENERIC_READ          As Long = &H80000000
Private Const GENERIC_WRITE         As Long = &H40000000
Private Const FILE_SHARE_READ       As Long = &H1&
Private Const FILE_SHARE_WRITE      As Long = &H2&
 
Private Const VER_PLATFORM_WIN32_NT As Long = &H2&
 
Public Function IsCDROMDriveOpen(ByVal drive As String) As DrvInfo
    Dim sys         As OSVERSIONINFOEX
    Dim SPT         As SPTD
    Dim hDrv        As Long
    Dim flags       As Long
    Dim BytesRet    As Long
    Dim lngStatus   As Long
    Dim buffer(7)   As Byte
 
    sys.dwOSVersionInfoSize = Len(sys)
    GetVersionEx sys
 
    flags = GENERIC_READ
    ' Ab Windows 2000 wird auch noch GENERIC_WRITE benötigt
    If sys.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        If sys.dwMajorVersion >= 5 Then
            flags = flags Or GENERIC_WRITE
        End If
    End If
 
    With SPT
        .Length = Len(SPT)
 
        ' max. 5 Sekunden Timeout
        .TimeOutValue = 5
 
        ' Daten in Datenbuffer empfangen
        .DataBuffer = VarPtr(buffer(0))
        .DataTransferLength = 8
        .DataIn = SCSI_IOCTL_DATA_IN
 
        .CdbLength = 10
        .cdb(0) = &H4A      ' Get Event/Status Notification
        .cdb(1) = &H1       ' IMMED Bit
        .cdb(4) = &H10      ' Media Events
        .cdb(8) = &H8       ' Datenzuweisungslänge (8 Bytes)
    End With
 
    ' Laufwerkshandle
    hDrv = CreateFile("\\.\" & Left$(drive, 1) & ":", flags, _
                      FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                      0, OPEN_EXISTING, 0, 0)
 
    If hDrv = INVALID_HANDLE_VALUE Then
        Err.Raise 12345, , "Ungültiges Laufwerkshandle"
        Exit Function
    End If
 
    ' Befehl an Laufwerk senden
    lngStatus = DeviceIoControl(hDrv, &H4D014, _
                                SPT, Len(SPT), _
                                SPT, Len(SPT), _
                                BytesRet, 0&)
 
    CloseHandle hDrv
 
    If lngStatus <> 1 Then
        Err.Raise 54321, , "Fehler beim Senden des CDBs"
        Exit Function
    End If
 
    If SPT.ScsiStatus <> 0 Then
        Err.Raise 123321, , "Befehl wahrscheinlich nicht unterstützt"
        Exit Function
    End If
 
    ' Bit 0 überprüfen ("Door or Tray open")
    ' Bit 1 überprüfen ("Media Present")
    With IsCDROMDriveOpen
        .open = CBool(buffer(5) And &H1)
        .diskpresent = CBool(buffer(5) And &H2)
    End With
End Function

http://rm_code.dl.am