Fil- och Mapphantering
FSOHär visas ett flertal tekniker för fil- och mapphantering mha av FileSystemObject (FSO).
Glöm inte av att ange referens till Microsoft Scripting Runtime - Läs mer här»
För tillämpning i Excel 97 krävs en egenutvecklad SPLIT-funktion som finns att tillgå här»
Option Explicit
'© 2002 Alla rättigheter XL-Dennis
Sub FilExisterar()
Dim fsoObj As Scripting.FileSystemObject
Set fsoObj = New Scripting.FileSystemObject
Dim stFil As String
stFil = "f:\Test\XL-Dennis\Test.xls"
If fsoObj.FileExists(stFil) Then
MsgBox "Filen existerar."
Else
MsgBox "Filen existerar inte."
End If
Set fsoObj = Nothing
End Sub
Sub MappExisterar()
Dim fsoObj As Scripting.FileSystemObject
Dim stVarde As String, stDir As String, stMapp As String
Dim vaSokvag As Variant
Dim i As Long
Set fsoObj = New Scripting.FileSystemObjectstDir = "f:\Test\XL-Dennis"
With fsoObj
If Not .FolderExists(stDir) Then
stVarde = MsgBox("Mappen finns ej att tillgå." & vbCrLf _
& "Vill du skapa mappen?", vbYesNo)
If Not stVarde = 6 Then Exit Sub
'Om Ja så skapa mappen.
With fsoObj
'Hämtar enhetsbeteckningen
stMapp = .GetDriveName(stDir) & Application.PathSeparator
'Split-funktionen finns att tillgå fr om version 2000.
vaSokvag = Split(Trim(stDir), "\")
'Här bygger vi upp sökvägen till mappen och skapar den.
For i = 1 To UBound(vaSokvag)
stMapp = .BuildPath(stMapp, vaSokvag(i))
.CreateFolder stMapp
Next i
MsgBox "Mappen skapad."
End With
'Alternativt kan följande kod användas för att skapa mappen.
'.CreateFolder "f:\Test"
'.CreateFolder "f:\Test\XL-Dennis"
Else
MsgBox "Mappen existerar."
End If
End With
Set fsoObj = Nothing
End Sub
Sub Kopiera_Alla_Filer()
Dim fsoObj As Scripting.FileSystemObject
Dim stMappFil As String
Set fsoObj = New Scripting.FileSystemObject
'Här anges att alla XL-filer i mappen ska kopieras.'Är det endast en fil som ska kopieras anges dess namn här.
stMappFil = "f:\Test\XL-Dennis\*.xls"
'Målmappen måste existera för att följande kommando ska fungera.
fsoObj.CopyFile Source:=stMappFil, Destination:="f:\Dennis\", OverWriteFiles:=True
MsgBox "Filerna kopierad."
'Existerar ej målmappen kan den skapas vid filkopieringen.With fsoObj
If .FolderExists("f:\Arbete\") Then
'Defaultvärdet för OverWriteFiles är True, vilket innebär att existerar filerna
'i målmappen skrivs dessa över utan förvarning.
.CopyFile Source:=stMappFil, Destination:="f:\Arbete\", OverWriteFiles:=True
MsgBox "Filerna kopierade till mappen f:\Arbete."
Else
.CreateFolder("f:\Arbetet")
.CopyFile Source:=stMappFil, Destination:=("f:\Arbetet\")
MsgBox "Mappen skapad och filerna kopierade."
End If
End With
Set fsoObj = Nothing
End Sub
Sub Kopiera_Mappar_Innehall()'Filer och undermappar som finns i källmappen kopieras till målmappen.
Dim fsoObj As Scripting.FileSystemObject
Dim stMappFil As String
Set fsoObj = New Scripting.FileSystemObject
stMappFil = "f:\Test\XL-Dennis"
'Om målmappen inte existerar så skapas den och källmappens innehållet kopieras dit.
fsoObj.CopyFolder Source:=stMappFil, Destination:="f:\Hem", OverWriteFiles:=True
MsgBox "Mappen kopierad."
Set fsoObj = Nothing
End Sub
Sub Radera_Fil()
'Filen raderas fullständigt och flyttas ej till papperskorgen.
Dim fsoObj As Scripting.FileSystemObject
Dim stMapp As String, stFil As String
Set fsoObj = New Scripting.FileSystemObject
stMapp = "f:\Test\XL-Dennis"stFil = "Test.xls"
With fsoObj
If .FolderExists(stMapp) And .FileExists(stMapp & "\" & stFil) Then
.DeleteFile stMapp & "\" & stFil, True
MsgBox "Filen raderad."
Else
MsgBox "Antingen saknas mappen och/eller filen."
End If
End With
Set fsoObj = Nothing
End Sub
Sub Radera_Filer()
'Filerna raderas fullständigt och flyttas ej till papperskorgen.
Dim fsoObj As Scripting.FileSystemObject
Dim fsoMapp As Scripting.Folder
Dim fsoFil As Scripting.File
Set fsoObj = New Scripting.FileSystemObjectSet fsoMapp = fsoObj.GetFolder("f:\Test\XL-Dennis\")
'Här räknas antal filer mappen innehåller.
MsgBox "Det finns " & fsoMapp.Files.Count & " st filer i mappen " & vbCrLf _
& fsoMapp.Path
For Each fsoFil In fsoMapp.FilesfsoObj.DeleteFile (fsoFil)
Next fsoFil
MsgBox "Alla filer är raderade."
Set fsoMapp = Nothing
Set fsoFil = Nothing
Set fsoObj = Nothing
End Sub
Sub TaBort_Mappar_Innehall()
'Huvudmapp, underliggande mappar och filerna raderas
'helt och flyttas ej till papperskorgen.
Dim fsoObj As Scripting.FileSystemObject
Dim stMappFil As String
Set fsoObj = New Scripting.FileSystemObject
stMappFil = "f:\Test"
With fsoObj
If .FolderExists(stMappFil) Then
.DeleteFolder stMappFil
MsgBox "Mappen och dess innehåll raderad."
Else
MsgBox "Mappen existerar ej."
End If
End With
Set fsoObj = Nothing
End Sub
Sub Flytta_Filer()
Dim fsoObj As Scripting.FileSystemObject
Dim stMappFil As String, stMalMapp As String
Set fsoObj = New Scripting.FileSystemObject
stMappFil = "f:\Test\XL-Dennis\*.xls"
stMalMapp = "f:\Hem\"
'Målmappen måste existera alternativt skapas innan filer flyttas.
'Om en eller flera filer existerar i målmappen kan inte dess skriva över
'utan den situationen måste hanteras för sig.
With fsoObj
If .FolderExists(stMalMapp) = False Then
.MoveFile Source:=stMappFil, Destination:=fsoObj.CreateFolder(stMalMapp)
Else
.MoveFile Source:=stMappFil, Destination:=stMalMapp
End If
End With
MsgBox "Filerna flyttade."
Set fsoObj = Nothing
End Sub
Sub Flytta_Mappar()
Dim fsoObj As Scripting.FileSystemObject
Dim stKallMapp As String, stMalMapp As String, stVarde As String
Set fsoObj = New Scripting.FileSystemObject
stKallMapp = "f:\Test\XL-Dennis"
stMalMapp = "f:\Hem"
'Om målmappen redan existerar måste den situationen lösas.
'Här visas en möjlig lösning.
With fsoObj
If .FolderExists(stMalMapp) Then
stVarde = MsgBox("Målmappen existerar redan." & vbCrLf _
& "Vill du ta bort mappen?", vbYesNo)
If stVarde <> 6 Then Exit Sub
.DeleteFolder (stMalMapp)
End If
.MoveFolder stKallMapp, stMalMapp
MsgBox "Mappen är flyttad."
End With
Set fsoObj = Nothing
End Sub