Lista fil- och mappegenskaper
FSOHär demonstreras ett flertal fil- och mappegenskaper, vilka vi kan arbeta med i ett flertal sammanhang.
Även egenskaper för hårddiskar och andra medier listas i en separat procedur.Tipsen finns ej tillgängliga för hämtning.
Glöm inte av att ange referens till Microsoft Scripting Runtime - Läs mer här»
Option Explicit
Sub Lista_Filer()
'© 2002 Alla rättigheter XL-Dennis
Dim fsoObj As Scripting.FileSystemObject
Dim fsoMapp As Scripting.Folder
Dim fsoFil As Scripting.File
Dim i As Long
Set fsoObj = New Scripting.FileSystemObject
Set fsoMapp = fsoObj.GetFolder("e:\Arbetsmaterial")
With Range("A1:H1")
.Value = Array("Filnamn", "Skapad", "Senast ändrad", "Storlek", "Typ", _
"Enhet", "Mapp", "Sökväg")
.Font.Bold = True
End With
i = 0
If Not fsoMapp Is Nothing Then
For Each fsoFil In fsoMapp.Files
If fsoFil Like "*.xls" Then
i = i + 1
With fsoFil
Cells(1 + i, 1).Value = .Name
Cells(1 + i, 2).Value = .DateCreated
Cells(1 + i, 3).Value = .DateLastModified
Cells(1 + i, 4).Value = .Size
Cells(1 + i, 5).Value = .Type
Cells(1 + i, 6).Value = .Drive
Cells(1 + i, 7).Value = .ParentFolder
Cells(1 + i, 8).Value = .Path
End With
End If
Next
End If
Columns("A:H").EntireColumn.AutoFit
Set fsoFil = Nothing
Set fsoMapp = Nothing
Set fsoObj = Nothing
End Sub
Sub Lista_Mappar()
'© 2002 Alla rättigheter XL-Dennis
Dim fsoObj As Scripting.FileSystemObject
Dim fsoMapp As Scripting.Folder
Dim fsoUMapp As Scripting.Folders
Dim vaFolder As Variant
Dim i As Long
Set fsoObj = New Scripting.FileSystemObject
Set fsoMapp = fsoObj.GetFolder("e:\Arbetsmaterial\")
Set fsoUMapp = fsoMapp.SubFolders
With Range("A1:E1")
.Value = Array("Mappnamn", "Skapad", "Sökväg", "Huvudmapp", "Enhet")
.Font.Bold = True
End With
i = 0
For Each vaFolder In fsoUMapp
i = i + 1
Cells(1 + i, 1).Value = vaFolder.Name
Cells(1 + i, 2).Value = vaFolder.DateCreated
Cells(1 + i, 3).Value = vaFolder.Path
Cells(1 + i, 4).Value = vaFolder.ParentFolder
Cells(1 + i, 5).Value = vaFolder.Drive
Next
Columns("A:E").EntireColumn.AutoFit
Set fsoUMapp = Nothing
Set fsoMapp = Nothing
Set fsoObj = Nothing
End Sub
Här demonstreras ett flertal egenskaper för hårddiskar och andra medier, vilka vi också kan arbeta med i ett flertal sammanhang.
Sub Lista_Enheter()
'© 2002 Alla rättigheter XL-Dennis
Dim fsoObj As Scripting.FileSystemObject
Dim fsoEnhet As Scripting.Drive
Dim stDisktyp As String, stSerienr As String
Dim i As Long
Set fsoObj = New Scripting.FileSystemObject
With Range("A1:H1").Value = Array("Enhetsnamn", "Enhetsbeteckning", "Rotkatalog", _
"Disktyp", "Filsystem", "Storlek (Bytes)", _
"Tillgängligt Utrymme (Bytes)", "Serienummer")
.Font.Bold = True
End With
i = 0
For Each fsoEnhet In fsoObj.Drives
i = i + 1
'Saknas diskett i diskettstationen eller 'saknas CD/DVD-skiva i CD/DVD-enheter eller
'saknas band/skiva i en extern enhet är egenskapen IsReady = False.
If fsoEnhet.IsReady Then
With fsoEnhet
Cells(1 + i, 1).Value = .VolumeName
Cells(1 + i, 2).Value = .DriveLetter
Cells(1 + i, 3).Value = .RootFolder
Select Case .DriveType
Case Fixed
stDisktyp = "Stationär"
Case Remote
stDisktyp = "Extern"
Case Removable
stDisktyp = "Flyttbar"
Case CDRom
stDisktyp = "CD-ROM"
Case RamDisk
stDisktyp = "RAM-disk"
End Select
Cells(1 + i, 4).Value = stDisktyp
Cells(1 + i, 5).Value = .FileSystem
Cells(1 + i, 6).Value = .TotalSize
'Alternativt kan egenskapen AvailableSpace användas här.
Cells(1 + i, 7).Value = .FreeSpace
'Egenskapen Serienummer uttrycks hexadecimalt varför formatering
'måste ske innan det skrivs ut.
stSerienr = Right(String(8, "0") & Hex(.SerialNumber), 8)
Cells(1 + i, 8).Value = Format(stSerienr, "@@@@-@@@@")
End With
End If
Next fsoEnhet
Columns("A:H").EntireColumn.AutoFitSet fsoEnhet = Nothing
Set fsoObj = Nothing
End Sub