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

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

   

' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butProperties_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder)
    Me.progress = _
        "Name: " & f1.Name & vbCrLf & _
        "Path: " & f1.Path & vbCrLf & _
        "Attributes: " & f1.Attributes & vbCrLf & _
        "DateCreated: " & f1.DateCreated & vbCrLf & _
        "LastAccessed: " & f1.DateLastAccessed & vbCrLf & _
        "LastModified: " & f1.DateLastModified & vbCrLf & _
        "IsRootFolder: " & f1.IsRootFolder & vbCrLf & _
        "ShortName: " & f1.ShortName & vbCrLf & _
        "ShortPath: " & f1.ShortPath & vbCrLf & _
        "Size: " & f1.Size & vbCrLf & _
        "Type: " & f1.Type & vbCrLf & _
        "fs.FolderExists('c:\')=" & fs.FolderExists("c:\") & vbCrLf & _
        ""

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub


' Получение имени специальной папки
'   fs.GetSpecialFolder(0) - 'c:\windows'
'   fs.GetSpecialFolder(1) - 'c:\windows\system'
'   fs.GetSpecialFolder(2) - 'c:\windows\temp
' Получение других имен
'   fs.GetFolder(".") - текущая папка
'   fs.GetFolder("..") - корневая папка
' Проверки для c:
'   fs.FolderExists("c:\") = True - есть на диске
'   fs.GetFolder("c:\").IsRootFolder = True - корневая папка
'
Private Sub butViewSpecFolder_Click()
On Error GoTo 999
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Me.progress = _
        "Папка Windows: " & fs.GetSpecialFolder(0) & vbCrLf & _
        "Папка System: " & fs.GetSpecialFolder(1) & vbCrLf & _
        "Папка Temp: " & fs.GetSpecialFolder(2) & vbCrLf & _
        "Текущая папка: " & fs.GetFolder(Me.myFolder & "\.") & vbCrLf & _
        "Родительская папка: " & fs.GetFolder(Me.myFolder & "\..") & vbCrLf & _
        ""
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub


' Получить список файлов
'   fs.GetFolder(".").Files
'
Private Sub butViewFiles_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).Files
    Me.progress = "Count=" & fc.Count & vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress & f1.Name & vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub


' Получить список подчиненных папок
'   fs.GetFolder(".").SubFolders
'
Private Sub butViewSubFolders_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).SubFolders
    Me.progress = "Count=" & fc.Count & vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress & f1.Name & vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub


' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butDrive_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder).drive
    Me.progress = _
        "DriveLetter: " & f1.DriveLetter & vbCrLf & _
        "AvailableSpace: " & f1.AvailableSpace & vbCrLf & _
        "DriveType: " & f1.DriveType & vbCrLf & _
        "FileSystem: " & f1.FileSystem & vbCrLf & _
        "FreeSpace: " & f1.FreeSpace & vbCrLf & _
        "IsReady: " & f1.IsReady & vbCrLf & _
        "Path: " & f1.Path & vbCrLf & _
        "SerialNumber: " & f1.SerialNumber & vbCrLf & _
        "ShareName: " & f1.ShareName & vbCrLf & _
        "TotalSize: " & f1.TotalSize & vbCrLf & _
        "VolumeName: " & f1.VolumeName
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub


'==============================================================
Private Sub Form_Open(Cancel As Integer)
    ' Устанавливаем каталог
    ChDir Application.CurrentProject.Path
    ' Определение имени новой папки
    Me.myFolder = Application.CurrentProject.Path
End Sub

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