Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0772: Status einer CD/DVD-Laufwerkslade ermitteln

 von 

Beschreibung 

Dieser Code zeigt wie der Status einer CD/DVD-Laufwerkslade per SPTI ermittelt werden kann. Hierfür werden allerdings Adminrechte benötigt da sonst CreateFile und DeviceIoControl fehlschlagen. Im Unterordner "aspi" liegt noch ein Beispiel bei das zeigt wie der Status per ASPI ermittelt werden kann. Für dieses Beispiel sollten keine Adminrechte benötigt werden. Voraussetzung ist aber ein korrekt installierter ASPI-Treiber von Adaptec.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CloseHandle, CreateFileA (CreateFile), DeviceIoControl, FormatMessageA (FormatMessage), GetDriveTypeA (GetDriveType), GetLogicalDrives

Download:

Download des Beispielprojektes [21.12 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei TrayStat.vbp -------------
'----- Anfang Formular "frmTrayStat" alias TrayStat.frm -----
' Steuerelement: Rahmensteuerelement "frDrive"
' Steuerelement: Schaltfläche "cmdClose" auf frDrive
' Steuerelement: Schaltfläche "cmdOpen" auf frDrive
' Steuerelement: Schaltfläche "cmdCheckTray" auf frDrive
' Steuerelement: Kombinationsliste "cbDrive" auf frDrive
' Steuerelement: Beschriftungsfeld "lblInfo" auf frDrive
Option Explicit

' ---=== Const ===---
' für FormatMessage
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const LANG_NEUTRAL As Long = &H0
Private Const SUBLANG_DEFAULT As Long = &H1

' für GetDriveType
Private Const DRIVE_CDROM As Long = &H5

' für CreateFile
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const OPEN_EXISTING As Long = &H3

' für DeviceIoControl dwIoControlCode
Private Const IOCTL_SCSI_PASS_THROUGH As Long = &H4D004
Private Const IOCTL_STORAGE_EJECT_MEDIA As Long = &H2D4808
Private Const IOCTL_STORAGE_LOAD_MEDIA As Long = &H2D480C

' für SCSI_PASS_THROUGH.CdbLength
Private Const CDB12GENERIC_LENGTH As Long = &HC

' für SCSI_PASS_THROUGH.DataIn
Private Const SCSI_IOCTL_DATA_IN As Long = &H1

' für SCSI_PASS_THROUGH.Cdb(0)
Private Const SCSIOP_MECHANISM_STATUS As Long = &HBD

' für SCSI_PASS_THROUGH.Cdb
Private Const CdbSize As Long = &H10

' für SCSI_PASS_THROUGH_WITH_BUFFERS.SenseBuf
Private Const SenseBufSize As Long = &H20

' für SCSI_PASS_THROUGH_WITH_BUFFERS.DataBuf
Private Const DataBufSize As Long = &H200

' für SCSI_PASS_THROUGH.ScsiStatus
Private Const SCSISTAT_GOOD As Long = &H0
Private Const SCSISTAT_CHECK_CONDITION As Long = &H2
Private Const SCSISTAT_CONDITION_MET As Long = &H4
Private Const SCSISTAT_BUSY As Long = &H8
Private Const SCSISTAT_INTERMEDIATE As Long = &H10
Private Const SCSISTAT_INTERMEDIATE_COND_MET As Long = &H14
Private Const SCSISTAT_RESERVATION_CONFLICT As Long = &H18
Private Const SCSISTAT_COMMAND_TERMINATED As Long = &H22
Private Const SCSISTAT_QUEUE_FULL As Long = &H28

' für SCSI_PASS_THROUGH_WITH_BUFFERS.SenseBuf(2)
' Sense Code
Private Const SCSI_SENSE_ILLEGAL_REQUEST As Long = &H5

' für SCSI_PASS_THROUGH_WITH_BUFFERS.SenseBuf(12)
' Additional Sense Codes (ASC)
Private Const SCSI_ADSENSE_ILLEGAL_COMMAND As Long = &H20

' ---=== Enum ===---
Private Enum Status
    TrayClosed = 0
    TrayOpen = 1
    TrayError = 2
    NoCdRomDrive = 3
    NoHandle = 4
    NoMechanismStatus = 5
End Enum

' ---=== Type ===---
Private Type SCSI_PASS_THROUGH
    Length As Integer
    ScsiStatus As Byte
    PathId As Byte
    TargetID As Byte
    Lun As Byte
    CdbLength As Byte
    SenseInfoLength As Byte
    DataIn As Byte
    FillBytes(0 To 2) As Byte
    DataTransferLength As Long
    TimeOutValue As Long
    DataBufferOffset As Long
    SenseInfoOffset As Long
    Cdb(0 To CdbSize - 1) As Byte
End Type

Private Type SCSI_PASS_THROUGH_WITH_BUFFERS
    Spt As SCSI_PASS_THROUGH
    SenseBuf(0 To SenseBufSize - 1) As Byte
    DataBuf(0 To DataBufSize - 1) As Byte
End Type

' ---=== Declare ===---
Private Declare Function CreateFile Lib "kernel32" _
                         Alias "CreateFileA" ( _
                         ByVal lpFileName As String, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal dwShareMode As Long, _
                         ByRef lpSecurityAttributes As Any, _
                         ByVal dwCreationDisposition As Long, _
                         ByVal dwFlagsAndAttributes As Long, _
                         ByVal hTemplateFile As Long) As Long
                         
Private Declare Function CloseHandle Lib "kernel32.dll" ( _
                         ByVal hObject As Long) As Long
                         
Private Declare Function DeviceIoControl Lib "kernel32.dll" ( _
                         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, _
                         ByRef lpOverlapped As Any) As Long
                         
Private Declare Function FormatMessage Lib "kernel32" _
                         Alias "FormatMessageA" ( _
                         ByVal dwFlags As Long, _
                         ByRef lpSource As Any, _
                         ByVal dwMessageId As Long, _
                         ByVal dwLanguageId As Long, _
                         ByVal lpBuffer As String, _
                         ByVal nSize As Long, _
                         ByRef Arguments As Long) As Long
                         
Private Declare Function GetDriveType Lib "kernel32" _
                         Alias "GetDriveTypeA" ( _
                         ByVal nDrive As String) As Long
                         
Private Declare Function GetLogicalDrives Lib "kernel32.dll" () As Long

' --------------------------------------------------------------------
' Funktion     : CDTray
' Beschreibung : Schublade eines CD-ROM Laufwerkes öffnen oder schliessen
' Übergabewert : Drive = Laufwerksbuchstaben
' Rückgabe     : True = Aktion erfolgreich
'                False = Aktion war nicht erfolgreich
' --------------------------------------------------------------------
Private Function CDTray(ByVal Drive As String, Optional ByVal OpenClose As Boolean _
    = True) As Boolean
    
    Dim hDevice As Long
    Dim lngRetByte As Long
    Dim lngControlCode As Long
    Dim bolRet As Boolean
    
    ' ist es ein CD-ROM Laufwerk
    If GetDriveType(Drive & ":\") = DRIVE_CDROM Then
    
        ' Handle auf das Laufwerk holen
        hDevice = CreateFile("\\.\" & Drive & ":", GENERIC_READ, FILE_SHARE_READ Or _
            FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0&, ByVal 0&)
            
        ' im Fehlerfall von DeviceIoControl Nachricht ausgeben
        Call ShowError(Err.LastDllError, "CreateFile")
            
        ' ist ein gültiges Handle vorhanden
        If hDevice <> INVALID_HANDLE_VALUE Then
        
            ' Öffnen oder Schließen
            If OpenClose Then
            
                ' Öffnen
                lngControlCode = IOCTL_STORAGE_EJECT_MEDIA
                
            Else
            
                ' Schließen
                lngControlCode = IOCTL_STORAGE_LOAD_MEDIA
                
            End If
            
            ' Nachricht an das Laufwerk senden
            bolRet = DeviceIoControl(hDevice, lngControlCode, ByVal 0&, 0&, ByVal _
                0&, 0&, lngRetByte, ByVal 0&)
                
            ' im Fehlerfall von DeviceIoControl Nachricht ausgeben
            Call ShowError(Err.LastDllError, "DeviceIoControl")
                
            ' Handle auf das Laufwerk schließen
            Call CloseHandle(hDevice)
            
        End If
    End If
    
    ' Status zurück geben
    CDTray = bolRet
    
End Function

' --------------------------------------------------------------------
' Funktion     : CDTrayIsOpen
' Beschreibung : Prüft ob die Schublade eines CD-ROM Laufwerkes offen oder
'                geschlossen ist. Der Code benötigt Adminrechte!!!
' Übergabewert : Drive = Laufwerksbuchstaben
' Rückgabe     : Enum Status
' --------------------------------------------------------------------
' Basiert auf einem Autoit-Script das auf
' http://www.autoitscript.com/forum/index.php?showtopic=73147
' zu finden ist. Entsprechend nach VB übersetzt und erweitert.
' --------------------------------------------------------------------
Private Function CDTrayIsOpen(ByVal Drive As String) As Status

    Dim hDevice As Long
    Dim lngItem As Long
    Dim lngRetByte As Long
    Dim tSPTWB As SCSI_PASS_THROUGH_WITH_BUFFERS
    
    ' ist es ein CD-ROM Laufwerk
    If GetDriveType(Drive & ":") = DRIVE_CDROM Then
    
        ' Handle auf das Laufwerk holen
        ' Benötigt Adminrechte!!!
        hDevice = CreateFile("\\.\" & Drive & ":", GENERIC_READ Or GENERIC_WRITE, _
            FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0&, ByVal _
            0&)
                    
        ' im Fehlerfall von CreateFile Nachricht ausgeben
        Call ShowError(Err.LastDllError, "CreateFile")
        
        ' ist ein gültiges Handle vorhanden
        If hDevice <> INVALID_HANDLE_VALUE Then
        
            ' Struktur SCSI_PASS_THROUGH_WITH_BUFFERS füllen
            With tSPTWB.Spt
                .Length = Len(tSPTWB.Spt)
                .CdbLength = CDB12GENERIC_LENGTH
                .SenseInfoLength = SenseBufSize
                .DataIn = SCSI_IOCTL_DATA_IN
                .DataTransferLength = DataBufSize
                .TimeOutValue = 2
                .DataBufferOffset = .Length + .SenseInfoLength
                .SenseInfoOffset = .Length
                .Cdb(0) = SCSIOP_MECHANISM_STATUS
                .Cdb(9) = &H8
            End With
            
            ' Mechanismus-Status vom Laufwerk auslesen
            If DeviceIoControl(hDevice, IOCTL_SCSI_PASS_THROUGH, tSPTWB, _
                Len(tSPTWB), tSPTWB, Len(tSPTWB), lngRetByte, ByVal 0&) = 1 Then
                
                ' im Fehlerfall von DeviceIoControl Nachricht ausgeben
                Call ShowError(Err.LastDllError, "DeviceIoControl")
                
                ' nach SCSI-Status selektieren
                Select Case tSPTWB.Spt.ScsiStatus
                
                Case SCSISTAT_GOOD ' Status ok
                
                    ' auswerten des Datenpuffers
                    If (tSPTWB.DataBuf(1) And &H10) = &H10 Then
                    
                        ' Schublade des Laufwerkes ist offen
                        CDTrayIsOpen = TrayOpen
                        
                    Else
                    
                        ' Schublade des Laufwerkes ist geschlossen
                        CDTrayIsOpen = TrayClosed
                        
                    End If
                    
                Case SCSISTAT_CHECK_CONDITION ' Status fehler
                
                    ' Der Status konnte nicht ermittelt werden. Mögliche
                    ' Ursache: Das Laufwerk unterstützt die Abfrage nicht.
                    CDTrayIsOpen = TrayError
                    
                    ' Debug-Ausgaben zur Information bei Fehlschlag.
                    
                    ' SCSI-Status Fehler ausgeben
                    Debug.Print "SCSI-Status Fehler = &H" & Hex$( _
                        tSPTWB.Spt.ScsiStatus) & " (" & CStr( _
                        tSPTWB.Spt.ScsiStatus) & ")"
                        
                    ' SenseBuf-Daten durchlaufen und ausgeben
                    ' hier stehen im Fehlerfall entsprechende
                    ' Fehlercodes zB. Sense Key / SenseBuf(2)
                    ' Additional sense code (ASC) / SenseBuf(12)
                    ' Additional sense code qualifier (ASCQ) / SenseBuf(13)
                    For lngItem = 0 To SenseBufSize - 1
                    
                        ' nur wenn Daten <> 0 sind
                        If tSPTWB.SenseBuf(lngItem) <> 0 Then
                        
                            ' SenseBuf-Daten ausgeben
                            Debug.Print "SenseBuf(" & CStr(lngItem) & ") = &H" & _
                                Hex$(tSPTWB.SenseBuf(lngItem)) & " (" & CStr( _
                                tSPTWB.SenseBuf(lngItem)) & ")"
                                
                        End If
                        
                    Next lngItem
                    
                    ' Sense Code ausgeben
                    Debug.Print "Sense Code = &H" & Hex$(tSPTWB.SenseBuf(2))
                    
                    ' Additional Sense Code ausgeben
                    Debug.Print "Additional Sense Code (ASC) = &H" & Hex$( _
                        tSPTWB.SenseBuf(12))
                        
                    ' Additional Sense Code Qualifier ausgeben
                    Debug.Print "Additional sense code qualifier (ASCQ) = &H" & _
                        Hex$(tSPTWB.SenseBuf(13))
                        
                    If tSPTWB.SenseBuf(2) = SCSI_SENSE_ILLEGAL_REQUEST And _
                        tSPTWB.SenseBuf(12) = SCSI_ADSENSE_ILLEGAL_COMMAND Then
                        
                        Debug.Print "Dieses Laufwerk unterstützt die Abfrage " & _
                            "nach dem SCSIOP_MECHANISM_STATUS nicht."
                            
                    End If
                
                Case Else ' andere SCSI-Fehler
                    CDTrayIsOpen = TrayError
                
                End Select
                
            Else
            
                ' konnte keine Mechanismus-Statusdaten vom Laufwerk erhalten
                CDTrayIsOpen = NoMechanismStatus
                
            End If
            
            ' Handle auf das Laufwerk schließen
            Call CloseHandle(hDevice)
            
        Else
        
            ' konnte kein gültiges Handle vom Laufwerk erhalten
            CDTrayIsOpen = NoHandle
            
        End If
        
    Else
    
        ' das Laufwerk ist kein CD-ROM Laufwerk
        CDTrayIsOpen = NoCdRomDrive
        
    End If
    
End Function

' --------------------------------------------------------------------
' Funktion     : ShowError
' Beschreibung : Gibt im Fehlerfall eine Nachricht aus
' Übergabewert : ErrNumber = Fehlernummer
'                Info = sonstiger Text
' --------------------------------------------------------------------
Private Sub ShowError(ByVal ErrNumber As Long, ByVal Info As String)

    Dim strBuf As String
    Dim lngErr As Long
    Dim lngRet As Long
    
    lngErr = ErrNumber
    
    ' ist ein Fehler aufgetreten
    If lngErr <> 0 Then
    
        ' Puffer erstellen
        strBuf = Space$(255)
        
        ' Fehlernummer konvertieren
        lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, lngErr, _
            LANG_NEUTRAL, strBuf, Len(strBuf), ByVal 0&)
            
        If lngRet > 0 Then
        
            ' Nachricht ausgeben
            MsgBox Info & " Error: " & Mid$(strBuf, 1, lngRet), vbOKOnly Or _
                vbInformation, "Error"
                
        End If
    End If
    
End Sub

Private Sub cmdCheckTray_Click()

    Dim strDrive As String
    
    ' sind Einträge in der ComboBox vorhanden
    If cbDrive.ListCount > 0 Then
    
        ' Laufwerksbuchstaben auslesen
        strDrive = Chr$(65 + cbDrive.ItemData(cbDrive.ListIndex))
        
        ' entsprechende Info ausgeben
        Select Case CDTrayIsOpen(strDrive)
        
        Case Status.TrayOpen
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ ist offen."
                
        Case Status.TrayClosed
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ ist geschlossen."
                
        Case Status.TrayError
        
            lblInfo.Caption = "Der Schubladen-Status vom CD-ROM Laufwerk " & _
                strDrive & ":\ konnte nicht ermittelt werden."
                
        Case Status.NoCdRomDrive
            lblInfo.Caption = "Das Laufwerk " & strDrive & ":\ ist kein CD-ROM Laufwerk."
            
        Case Status.NoHandle
        
            lblInfo.Caption = "Konnte kein gültiges Handle vom Laufwerk " & _
                strDrive & ":\ erhalten."
                
        Case Status.NoMechanismStatus
        
            lblInfo.Caption = "Konnte keine Mechanismus-Statusdaten vom " & _
                "Laufwerk " & strDrive & ":\ erhalten."
                
        End Select
        
    End If
    
End Sub

Private Sub cmdClose_Click()

    Dim strDrive As String
    
    ' sind Einträge in der ComboBox vorhanden
    If cbDrive.ListCount > 0 Then
    
        ' Laufwerksbuchstaben auslesen
        strDrive = Chr$(65 + cbDrive.ItemData(cbDrive.ListIndex))
        
        ' CD-Fach schließen
        If CDTray(strDrive, False) Then
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ wurde geschlossen."
                
        Else
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ konnte nicht geschlossen werden."
                
        End If
        
    End If
    
End Sub

Private Sub cmdOpen_Click()

    Dim strDrive As String
    
    ' sind Einträge in der ComboBox vorhanden
    If cbDrive.ListCount > 0 Then
    
        ' Laufwerksbuchstaben auslesen
        strDrive = Chr$(65 + cbDrive.ItemData(cbDrive.ListIndex))
        
        ' CD-Fach öffnen
        If CDTray(strDrive, True) Then
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ wurde geöffnet."
                
        Else
        
            lblInfo.Caption = "Die Schublade des CD-ROM Laufwerkes " & strDrive & _
                ":\ konnte nicht geöffnet werden."
                
        End If
        
    End If
    
End Sub

Private Sub Form_Load()

    Dim lngDriveNum As Long
    Dim lngRet As Long
    Dim strDriveName As String
    
    ' Button deaktivieren
    cmdCheckTray.Enabled = False
    cmdOpen.Enabled = False
    cmdClose.Enabled = False
    
    ' Inhalt vom Label löschen
    lblInfo.Caption = vbNullString
    
    ' alle Items in der ListBox löschen
    cbDrive.Clear
    
    ' alle verfügbare Laufwerke ermitteln
    lngRet = GetLogicalDrives
    
    ' alle Laufwerksnummern durchlaufen
    For lngDriveNum = 0 To 25
    
        ' ist das entsprechende Bit in lngRet <> 0
        If (lngRet And 2 ^ lngDriveNum) <> 0 Then
        
            ' Laufwerksbuchstabe
            strDriveName = Chr$(65 + lngDriveNum)
            
            ' Laufwerkstyp ermitteln (CDROM-Laufwerke)
            If GetDriveType(strDriveName & ":") = DRIVE_CDROM Then
            
                ' Daten in der ComboBox ausgeben und speichern
                cbDrive.AddItem strDriveName & ":\"
                cbDrive.ItemData(cbDrive.NewIndex) = lngDriveNum
                
            End If
        End If
        
        ' nächste Laufwerksnummer
    Next lngDriveNum
    
    ' sind Einträge in der ComboBox vorhanden
    If cbDrive.ListCount > 0 Then
    
        ' ersten Eintrag in der ComboBox auswählen
        cbDrive.ListIndex = 0
        
        ' Button aktivieren
        cmdCheckTray.Enabled = True
        cmdOpen.Enabled = True
        cmdClose.Enabled = True
        
    End If
    
End Sub



'------ Ende Formular "frmTrayStat" alias TrayStat.frm ------
'-------------- Ende Projektdatei TrayStat.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.