Программирование на Visual Basic

Этот пример покажет Вам как правильно определить различные свойства папок в Windows. Вы также сможете прочитать свойства томов, системных папок и т.п.

' Прочитать все свойства папки
'   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