Zjištění typů všech disků v systému

Do modulu zapište následující deklarace a procedury:
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

Public Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
*každá deklarace musí být celá na samostatné řádce

Public Function VBGetLogicalDriveStrings() As String

    'Vrací řetězec písmen přístupných disků
    'oddělených znakem chr$(0)
    Dim r As Long
    Dim i As Integer
    Dim tmp As String
    tmp$ = Space$(64)
    r& = GetLogicalDriveStrings(Len(tmp$), tmp$)
    VBGetLogicalDriveStrings = Trim$(tmp$)

End Function

Public Function StripNulls(startStrg$) As String

    'Vezme řetězec oddělovaný znakem chr$(0), vybere 1 položku,
    'zkrátí o ni vstupní řetězec a položku vrátí
    Dim c As Integer
    Dim item As String
    c% = 1
    Do
    If Mid$(startStrg$, c%, 1) = Chr$(0) Then
        item$ = Mid$(startStrg$, 1, c% - 1)
        startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))
        StripNulls$ = item$
        Exit Function
    End If
    c% = c% + 1
    Loop

End Function

Public Function rgbGetDriveType(RootPathName$) As String

    'Zpracovává jméno disku.
    'Vrací typ disku.
    Dim r As Long
    r& = GetDriveType(RootPathName$)
    Select Case r&
        Case 0: rgbGetDriveType$ = "Typ disku nemohl být zjištěn."
        Case 1: rgbGetDriveType$ = "Hlavní adresář nevytvořen."
        Case DRIVE_REMOVABLE
            Select Case Left$(RootPathName$, 1)
                Case "a", "b": rgbGetDriveType$ = "Disketa."
                Case Else: rgbGetDriveType$ = "Výměnný disk."
            End Select
        Case DRIVE_FIXED: rgbGetDriveType$ = "Pevný disk."
        Case DRIVE_REMOTE: rgbGetDriveType$ = "Připojený (síťový) disk."
        Case DRIVE_CDROM: rgbGetDriveType$ = "CD-ROM disk."
        Case DRIVE_RAMDISK: rgbGetDriveType$ = "RAM disk."
    End Select

End Function

Na událost Click tlačítka Command1 vložte tento kód:
Private Sub Command1_Click

    Dim r As Long
    Dim allDrives As String
    Dim currDrive As String
    Dim drvType As String
    'Seznam přístupných disků
    allDrives$ = VBGetLogicalDriveStrings()
    'Separování jména disku a zjištění jeho typu
    Do Until allDrives$ = Chr$(0)
       'Vyjmutí názvu disku z řetězce allDrives$
        currDrive$ = StripNulls$(allDrives$)
       'zjištění typu disku
        drvType$ = rgbGetDriveType(currDrive$)
        Debug.Print " " & UCase(currDrive$) & " - " & drvType$
    Loop

End Sub

Nyní spusťte aplikaci. Do okna Debug se Vám vypíše seznam přístupných disků a jejich typ.

Zpět