LEADERSOFT.ru Разработка на заказ программ и сайтов
ЕСЛИ БАЗА ВАМ НУЖНА В ЛИДЕРСОФТ ЗАЙДИ СПЕРВА!
Все примеры Microsoft Access - VBA


















































02. Этот пример показывает как с использованием API интерфейса определить информацию по дискам системы.

Все примеры Microsoft Access
' Запрашиваем информацию о диске
Private Declare Function apiGetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
    (ByVal lpRootPathName As String, _
        lpSectorsPerCluster As Long, _
        lpBytesPerSector As Long, _
        lpNumberOfFreeClusters As Long, _
        lpTotalNumberOfClusters As LongAs Long

'  Загрузка данных
Private Sub Form_Load()
    On Error Resume Next
    Me.myDrive.RowSource = funGetDrivers
    Me.myDrive = Me.myDrive.Column(0, 0)
    myDrive_AfterUpdate
    Err.Clear
End Sub


'  Получаем информацию о диске системы
Private Function funInformationDisk()
Dim fs, dc, D, s As String
On Error Resume Next
    s = ""
    ' 1. Получаем информацию из файловой системы
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each In dc
        If StrComp(D.DriveLetter, Left(myDrive, 1), vbTextCompare) = 0 Then
            s = s & "Серийный номер: " & D.SerialNumber & ";"
            s = s & "Емкость диска: " & Format(D.TotalSize, "#,0") & ";"
            s = s & "Доступный объем диска: " & Format(D.AvailableSpace, "#,0") & ";"
            s = s & "Свободное место на диске: " & Format(D.FreeSpace, "#,0") & ";"
            s = s & "Метка тома: " & D.VolumeName & ";"
            s = s & "Файловая система: " & D.FileSystem & ";"
            Exit For
        End If
        Err.Clear
    Next D
    ' 2. Получаем информацию из api интерфейса
    Dim SectorsPerCluster As Long ' Секторов на клястер
    Dim BytesPerSector As Long ' Байт на сектор
    Dim NumberOfFreeClustors As Long ' Свободных клястеров
    Dim TotalNumberOfClustors As Long ' Всего клястеров

    ' Запрашиваем свободное место
    Call apiGetDiskFreeSpace(Left(Me.myDrive, 2), _
        SectorsPerCluster, BytesPerSector, _
        NumberOfFreeClustors, TotalNumberOfClustors)
    s = s & "Число секторов на клястер: " & Format(SectorsPerCluster, "#,0") & ";"
    s = s & "Число байт на сектор: " & Format(BytesPerSector, "#,0") & ";"
    s = s & "Число свободных клястеров: " & Format(NumberOfFreeClustors, "#,0") & ";"
    s = s & "Всего клястеров: " & Format(TotalNumberOfClustors, "#,0") & ";"
    
    ' Используя клястеры Вы можете определить
    ' a) Емкость диска = TotalNumberOfClustors * SectorsPerCluster * BytesPerSector
    ' b) Свободное место = NumberOfFreeClustors * SectorsPerCluster * BytesPerSector
    
    ' 3. Присваиваем источник данных
    Me.myList.RowSource = s
    Exit Function
End Function


'  Заполняем список с информацией о дисках
Private Function funGetDrivers() As String
Dim fs, dc, D
Dim As String
On Error GoTo 999
    Err.Clear
    funGetDrivers = ""
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each In dc
        Select Case D.driveType
          Case 0: s = "Неизвестная БД"
          Case 1: s = "Дискета"
          Case 2: s = "Жесткий диск"
          Case 3: s = "Сетевой диск"
          Case 4: s = "CD-ROM"
          Case 5: s = "RAM диск"
        End Select
        If D.IsReady Then
           funGetDrivers = funGetDrivers & D.DriveLetter & ":\ - " & s & ";"
        End If
    Next
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
    funGetDrivers = ""
End Function


'  Обновляем информацию
Private Sub myDrive_AfterUpdate()
    funInformationDisk
End Sub