【Excel VBA】ファイルの絶対パスを取得する

カレントディレクトリ

Sub 使いないやつ()
    Debug.Print CreateObject("Scripting.FileSystemObject").GetAbsolutePathName("./")
    Debug.Print CurDir
End Sub

• どっちも、デフォルトだと%UsersProfile%\Documents（マイドキュメント）を指す。
• Excelのワークブックのパス基準の絶対パス取得は以下の通り。

Public Function AbsPath(String RelativePath) As String
On Error GoTo HANDLING
    Dim DirBK As String
    DirBK = CurDir
    ChDrive Left(ThisWorkbook.Path, 1)
    ChDir ThisWorkbook.Path
    AbsPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(RelativePath)
    ChDrive Left(DirBK, 1)
    ChDir DirBK
    Exit Function
    
HANDLING:
    Debug.Log ("[ERROR]AbsPath():" & ERR.Description)
    ERR.Raise ERR.Number, ERR.Source, ERR.Description, ERR.HelpFile, ERR.HelpContext
    
End Function()

• FileSystemObjectやChDirを使わないレシピ

Public Function AbsPath(Path As String) As String
On Error GoTo HANDLING

    If (InStr(Path, ":") <> 2) Then
        Path = ThisWorkbook.Path & "\" & Path
    Else
        Path = Path
    End If
    
    
    Dim idx As Long
    Do While InStr(Path, "..\") > 0
        idx = InStr(Path, "..\")
        
        Dim idxPrevSep As Long
        idxPrevSep = InStrRev(Path, "\", idx - 2)
        If (idxPrevSep = 0) Then
            Exit Do
        End If
        
        Path = Left(Path, idxPrevSep - 1) & Mid(Path, idx + 2)
    Loop
    
    Path = Replace(Path, ".\", "")
    AbsPath = Path
    
    Exit Function
    
HANDLING:
    Debug.Log ("[ERROR]AbsPath():" & ERR.Description)
    ERR.Raise ERR.Number, ERR.Source, ERR.Description, ERR.HelpFile, ERR.HelpContext
    
End Function