LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
02. Этот пример показывает как с использованием API интерфейса определить информацию по дискам системы.
Свойства продукта

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\16 Модули\API\la_api.mdb
 Язык интерфейса: Русский

   

' Запрашиваем информацию о диске
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

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access