VB 5/6-Tipp 0772: Status einer CD/DVD-Laufwerkslade ermitteln
von Frank Schüler
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:
| Verwendete API-Aufrufe: CloseHandle, CreateFileA (CreateFile), DeviceIoControl, FormatMessageA (FormatMessage), GetDriveTypeA (GetDriveType), GetLogicalDrives | Download: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
| VB4 |  | | | | | | |
| VB5 | | | | | | | |
| VB6 | | | | | | | |
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.