Detekce CD-ROM

Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6

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
* každá deklarace musí být na samostatné řádce

Založte novou proceduru DetectCDROM:

Public Sub DetectCDROM

   Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&
   Dim CDfound As Integer

   'Definice místa v proměnné
   allDrives$ = Space$(64)

   'Získání jmen všech disků
   r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)

   'oříznutí koncových chr$(0). AllDrives$
   'nyní bude obsahovat pouze jména disků.
   allDrives$ = Left$(allDrives$, r&)

   'cyklus
   Do
      'Nalezení prvního oddělovače chr$(0)
      pos% = InStr(allDrives$, Chr$(0))
      'pokud nalezeno ....
      If pos% Then
            'zjištění disku k chr$(0)
           JustOneDrive$ = Left$(allDrives$, pos%)
           'a odstranění z řetězce allDrives$, aby se netestoval znovu
           allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
          's vybraným diskem zavolat API pro zjištění tipu disku 
          DriveType& = GetDriveType(JustOneDrive$)
          'Je-li to CD ROM
           If DriveType& = DRIVE_CDROM Then
               CDfound% = True
               Exit Do
           End If
      End If
   Loop Until allDrives$ = "" Or DriveType& = DRIVE_CDROM

   If CDfound% Then
        MsgBox "CD-ROM - disk " & UCase$(JustOneDrive$)
   Else
        MsgBox "Tento počítač nemá CD_ROM."
   End If

End Sub

Zpět