【VBA】fsoを使ったDir関数

File I/OではOneDriveにアクセスできない

Open、Close、Input、Line Input、Print、Write、Get、Putなどの古いファイルアクセスIFでは、OneDriveのフォルダにアクセスできません。これらIFを使っていると、OneDriveとリンクしているフォルダを踏むとエラーが発生しています。

fsoを使った場合の問題点

そこでfsoを使ってファイルへアクセスすることになりますが、この場合の問題としては、Dir()に相当とする関数が存在しており、これまでDir()を使っていたコードの移植性が悪くなってしまいます。特にDir()を繰り返してファイル名を得ているコードはどのように記述していいか頭を悩ませることになります。

fsoを使ったDir関数

そこでChatGTPの手を借りて、Dir関数に相当するDirUsingFSOという関数を書いてみました。

Option Explicit

Dim fso As Object
Dim folder As Object
Dim filesAndFolders As Collection
Dim currentIndex As Integer

Sub InitFSO_Dir(Optional path As String, Optional attributes As Variant)
Dim file As Object
Dim subfolder As Object

Set fso = CreateObject("Scripting.FileSystemObject")

If path = "" Or IsMissing(path) Then
    path = fso.GetAbsolutePathName(".")
    
ElseIf Not IsMissing(attributes) Then
    If attributes = vbDirectory Then
        Set folder = fso.GetFolder(path)
    Else
        MsgBox "DirUsingFunction No2 Second argument is wrong " & attributes
        End
    End If
ElseIf IsMissing(attributes) Then
    Dim lastPositionOfDev As Long
        lastPositionOfDev = FindLastCharIndex(path, "\")
    
    Dim folderName As String
        folderName = Left(path, lastPositionOfDev)
    
    Dim fileName As String
        fileName = Right(path, Len(path) - lastPositionOfDev)
            
    Set folder = fso.GetFolder(folderName)
Else
    MsgBox "Second parameter Is not vbDirectory"
    End
End If

Set filesAndFolders = New Collection

currentIndex = 0

' Populate the files and folders collection
If Not IsMissing(attributes) Then
    If attributes = vbDirectory Then
        For Each subfolder In folder.SubFolders
            filesAndFolders.Add subfolder.name
        Next subfolder
    Else
        MsgBox "DirUsingFunction No2 Second argument is wrong " & attributes
        End
    End If
Else
    For Each file In folder.Files
    
        If file Like fileName Then
        
            ' システム属性を判定して、システムファイルの場合はスキップ
            If (file.attributes And (vbSystem Or vbHidden)) = 0 Then
                If file Like fileName Then
                    filesAndFolders.Add file.name
                End If
            Else
                '処理なし
            End If
            
        End If
    Next file
End If
Set fso = Nothing
End Sub

'======================================
Function DirUsingFSO(Optional path As String, Optional attributes As Variant) As String

If path <> "" And Not IsMissing(path) Then
　Call InitFSO_Dir(path, attributes)
End If

currentIndex = currentIndex + 1
If currentIndex <= filesAndFolders.Count Then
    DirUsingFSO = filesAndFolders.item(currentIndex)
Else
    DirUsingFSO = ""
    currentIndex = 0 ' Reset index for potential next search in a new directory
End If

End Function