Lag en liste over filer i en mappe med Office 95 eller tidligere

Office95 eller tidligere har ikke den samme enkle metoden til å få tak i mappe- og filnavn som Office97 har. Ved å lage 4 hjelpefunksjoner kan man få til tilnærmet samme funksjonalitet:
Dim GlobalFolderList() As String, GlobalFolderCount As Long

Function FolderList95(InputFolder As String) As Variant
' returns an array containing the folders in InputFolder
Dim rootFolder As String, Folder As String
Dim Folders() As String, FolderCount As Long
    rootFolder = InputFolder
    If Right(rootFolder, 1) <> "" Then rootFolder = rootFolder & ""
    Folder = Dir(rootFolder, vbDirectory) ' retrieve the first folder.
    FolderCount = 0
    While Folder <> "" ' start the loop.
        ' ignore the current directory and the encompassing directory.
        If Folder <> "." And Folder <> ".." Then
            ' Use bitwise comparison to make sure Folder is a directory.
            On Error GoTo FileInUse
            If (GetAttr(rootFolder & Folder) And vbDirectory) = vbDirectory Then
                FolderCount = FolderCount + 1
                ReDim Preserve Folders(FolderCount)
                Folders(FolderCount) = Folder
            End If
        End If
FileInUse:
        Folder = Dir() ' get next folder
    Wend
    FolderList95 = Folders
    ' if you only want to return the number of folders: 
    ' return the value FolderCount
End Function

Sub RecursiveFolderList95(ByVal InputFolder As String, _
    IncludeSubFolders As Boolean)
' adds the folders in InputFolder and any subfolders to 
' the global variable GlobalFolderList
Dim rootFolder As String, SubFolders As Variant
Dim i As Long
    rootFolder = InputFolder
    If rootFolder = "" Then Exit Sub
    If GlobalFolderCount = 0 Then
        GlobalFolderCount = 1
        ReDim Preserve GlobalFolderList(GlobalFolderCount)
        GlobalFolderList(GlobalFolderCount) = rootFolder
    End If
    If Right(rootFolder, 1) <> "" Then rootFolder = rootFolder & ""
    SubFolders = FolderList95(rootFolder)
    On Error GoTo NoFolder
    If TypeName(SubFolders) = "String()" Then ' folders found
        For i = 1 To UBound(SubFolders)
            GlobalFolderCount = GlobalFolderCount + 1
            ReDim Preserve GlobalFolderList(GlobalFolderCount)
            GlobalFolderList(GlobalFolderCount) = rootFolder & SubFolders(i)
            If IncludeSubFolders Then
                RecursiveFolderList95 rootFolder & SubFolders(i), IncludeSubFolders
            End If
        Next i
    End If
NoFolder:
    Erase SubFolders
End Sub

Function FolderFileList95(ByVal InputFolder As String, _
    FileFilter As String) As Variant
' returns an array containing the files matching the FileFilter in InputFolder
Dim List() As String, tFile As String, fCount As Long
    FolderFileList95 = ""
    If InputFolder = "" Then InputFolder = CurDir
    If Right(InputFolder, 1) <> "" Then InputFolder = InputFolder & ""
    If FileFilter = "" Then FileFilter = "*.*"
    tFile = Dir(InputFolder & FileFilter)
    fCount = 0
    While tFile <> ""
        fCount = fCount + 1
        ReDim Preserve List(fCount)
        List(fCount) = tFile
        tFile = Dir
    Wend
    If fCount > 0 Then FolderFileList95 = List
    ' if you only want to return the number of files: 
    ' return the value fCount
    Erase List
End Function

Function CreateFileList95(FileFilter As String, _
    IncludeSubFolder As Boolean) As Variant
' returns the full filename for files matching the filter criteria 
' in the current folder
Dim FileList() As String, FileCount As Long, f As Long
Dim tempList As Variant, i As Long
    Erase GlobalFolderList 
    ' global variable: Dim GlobalFolderList() as String
    GlobalFolderCount = 0 
    ' global variable: Dim GlobalFolderCount as Long
    If FileFilter = "" Then FileFilter = "*.*" ' all files
    Application.StatusBar = "Reading folder information..."
    RecursiveFolderList95 CurDir, IncludeSubFolder
    If GlobalFolderCount > 0 Then ' folders found, find files
        Application.StatusBar = "Reading file information..."
        For f = 1 To GlobalFolderCount
            tempList = FolderFileList95(GlobalFolderList(f), FileFilter)
            If TypeName(tempList) = "String()" Then
                For i = 1 To UBound(tempList)
                    FileCount = FileCount + 1
                    ReDim Preserve FileList(FileCount)
                    FileList(FileCount) = GlobalFolderList(f) & "" & tempList(i)
                Next i
            End If
        Next f
    End If
    CreateFileList95 = FileList
    ' if you only want to return the number of files: return the value FileCount
    Erase GlobalFolderList
    Erase FileList
    Application.StatusBar = False
End Function


Sub TestCreateFileList95()
Const SearchRootFolder as String = "C:\My Documents"
Dim MyFiles As Variant, i As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating file list..."
    ChDrive Left(SearchRootFolder, 1) ' activate the desired drive
    ChDir SearchRootFolder ' activate the desired folder
    MyFiles = CreateFileList95("*.xls", True)
    i = 0
    On Error Resume Next
    i = Ubound(MyFiles)
    On Error Goto 0
    If i = 0 Then ' no files found
        MsgBox "No files matches the file criteria!"
        Exit Sub
    End If
    Workbooks.Add
    With Range("A1")
        .Formula = "List of *.xls-files in " & CurDir & " and subfolders:"
        .Font.Bold = True
    End With
    For i = 1 To UBound(MyFiles)
        Cells(i + 1, 1).Formula = MyFiles(i)
    Next i
    Columns("A").AutoFit
    Application.StatusBar = False
End Sub
Dokumentet er sist oppdatert 2000-02-04 12:34:02 Utskriftsvennlig versjon