Scripting.Drives   strona główna:
A po co ten Excel ;-)
 
Już od jakiegoś czasu chciałbym ruszyć coś z biblioteki Scripting Runtime no i w końcu zacznę :-)  
    Padło na Scripting.Drives :-). A więc informacje o dostępnych dyskach.   
Najpierw w pustym arkuszu odpalmy sobie taką procedurkę (żywcem z mojego archiwum):  
 
Sub ScriptingDrives()  
    Dim objFSO As Object 'Scripting.FileSystemObject  
    Dim colDrives As Object 'Scripting.Drives  
    Dim objDrive As Object 'Scripting.Drive  
    Dim i As Long  
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set colDrives = objFSO.Drives  
      
    '---------Scripting.DriveTypeConst----------  
    Const UnknownType = 0       ' (??)  
    Const Removalbe = 1         ' Dyskietka (A:) , Dyski przenośne (pen'y)  
    Const Fixed = 2             ' Partycje dysku twardego  
    Const Remote = 3            ' Dyski sieciowe  
    Const CDRom = 4             ' (wiadomo)  
    Const RamDisk = 5           ' (??)  
    '-------------------------------------------  
    On Error Resume Next  
    For Each objDrive In colDrives  
        i = i + 1  
        Cells(i, "A") = objDrive.AvailableSpace   ' wolne miejsce  
        Cells(i, "B") = objDrive.DriveLetter      ' litera  
        Cells(i, "C") = objDrive.DriveType        ' typ  
        Cells(i, "D") = objDrive.FileSystem       ' system plików (FAT32/NTFS)  
        Cells(i, "E") = objDrive.IsReady          ' czy gotowy (Boolean)  
        Cells(i, "F") = objDrive.Path             ' ścieżka (A:)  
        Cells(i, "G") = objDrive.RootFolder       ' folder (A:\)  
        Cells(i, "H") = objDrive.SerialNumber     ' nr seryjny  
        Cells(i, "I") = objDrive.ShareName        ' ścieżka dla dysków sieciowych \\serwer\współny  
        Cells(i, "J") = objDrive.TotalSize        ' wielkość  
        Cells(i, "K") = objDrive.VolumeName  
    Next  
    Set objFSO = Nothing  
    Set colDrives = Nothing  
End Sub  
 
No i po co nam ta wiedza??  
Przykład.1  
Chcemy zapisać kopię naszego skoroszytu na dysku przenośnym ale jak jest jego litera??  
 
Function SciezkaDyskuPrzenosnego() As String  
    Dim objFSO As Object 'Scripting.FileSystemObject  
    Dim colDrives As Object 'Scripting.Drives  
    Dim objDrive As Object 'Scripting.Drive  
      
    Const Removalbe = 1  
      
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set colDrives = objFSO.Drives  
    For Each objDrive In colDrives  
        With objDrive  
            If .DriveType = Removalbe And .IsReady And .DriveLetter <> "A" Then  
                SciezkaDyskuPrzenosnego = .RootFolder  
                Exit For  
            End If  
        End With  
    Next  
    Set objFSO = Nothing  
    Set colDrives = Nothing  
End Function  
 
Przykład.2  
Ciekawy przykład zabezpieczenia:  
KasiaP: da zablokować plik Excela przed kopiowaniem żeby po skopiowaniu i otwarciu na innym komp. wyskakiwała informacja w stylu   
"OTWARCIE PLIKU NIEMOZLIWE.PRZED KOPIOWANIEM ZAPYTAJ WLASCICIELA CZY MOZESZ SKOPIOWAC"    link do tematu
 
Function MojTest() As Boolean  
    On Error GoTo MojTest_Error  
 
    Dim objFSO As Object  
    Dim objDrive    As Object  
     
    Const nr As Long = 109639519  
     
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objDrive = objFSO.Drives("C:")  
     
    'Debug.Print objDrive.SerialNumber  
    If objDrive.SerialNumber = nr Then MojTest = True  
     
MojTest_Exit:  
    Set objFSO = Nothing  
    Set objDrive = Nothing  
    Exit Function  
 
MojTest_Error:  
    MsgBox "Błąd nr - " & Err.Number & vbCrLf & vbCrLf & _  
           Err.Description, vbExclamation, "VBAProject - TestAutoryzacji"  
    Resume MojTest_Exit  
 
End Function  
 
Przykład.3  
Plik do którego musimy się odwołać znajduje się na dysku przenośnym. Jak pobrać z niego dane?   link do przykładu
 
Function DateBasePath(strConstPathPart As String) As String  
    Dim objFSO As Object ' Scripting.FileSystemObject  
    Dim colDrives As Object 'Scripting.Drives  
    Dim objDrive As Object 'Scripting.Drive  
     
    If Left(strConstPathPart, 1) <> "\" Then strConstPathPart = "\" & strConstPathPart  
     
    Const Removable = 1  
     
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set colDrives = objFSO.Drives  
 
    On Error Resume Next  
    For Each objDrive In colDrives  
        With objDrive  
        'Debug.Print .DriveLetter  
            If .DriveType = Removable And .IsReady Then  
                If Dir(.Path & strConstPathPart) <> vbNullString Then  
                    DateBasePath = .Path & strConstPathPart  
                    Exit For  
                End If  
            End If  
        End With  
    Next  
    Set objFSO = Nothing  
    Set colDrives = Nothing  
End Function