Excelブックのフォルダパスやフルパスを取得。法人向けと個人向けのOneDriveの両方に対応。

Private Sub test()
    MsgBox getFolderPathFromBook(ActiveWorkbook) _
        & vbCrLf & getFullPathFromBook(ActiveWorkbook)
End Sub

'*******************************
'* ブックからフォルダパスを取得。ファイル名除く。One Drive対応。
'* 戻り値：ブックのフォルダパス
'* wb：開いているWorkbookを指定
Function getFolderPathFromBook(ByVal wb As Workbook) As String

    Dim url As String, localPath As String
    Dim oneDrivePath As String, cloudPattern As String
    
    ' ブックのPathを取得
    url = wb.path
    
    ' クラウド上でなければ終了
    If Not url Like "https*" Then
        getFolderPathFromBook = url
        Exit Function
    End If
    
    ' 法人向けOneDriveのURLか否かを判定するためのLike右辺値
    Const Cns_OneDrive法人パターン As String = "*my.sharepoint.com*"
    
    ' 法人向けOneDrive:S_Url="https://会社名-my.sharepoint.com/personal/ユーザー名_domain_com/Documentsファイルパス")
    If (url Like Cns_OneDrive法人パターン) Then
        'OneDrive用フォルダーのパスを取得
        '法人用
        oneDrivePath = Environ("OneDriveCommercial")
        If oneDrivePath = "" Then oneDrivePath = Environ("OneDrive")
    
        'パターン文字列指定  ' 「/Documents」を追加
        cloudPattern = "https://.+my.sharepoint.com/personal/[^/$]+/Documents"     '法人用
        ' .+ は正規表現で、次のような意味を持ちます：
        ' .：改行を除く任意の1文字を表します。
        ' +：直前のパターンが1回以上繰り返されることを表します。
        ' つまり、この正規表現は「改行を除く任意の文字が1文字以上連続する部分」にマッチします。
            
        ' [^/$] は正規表現で､次のような意味を持ちます:
        ' ^...:   角括弧の中にある文字以外の任意の1文字を表します｡
        ' [^/$]：スラッシュ / またはドル記号 $ 以外の任意の1文字を表します。
        ' +：直前のパターンが1回以上繰り返されることを表します。
        ' つまり、この正規表現は「スラッシュ / またはドル記号 $ 以外の文字が1文字以上連続する部分」にマッチします。
    
    Else
        'OneDrive用フォルダーのパスを取得
        '個人用
        oneDrivePath = Environ("OneDrive")
        If oneDrivePath = "" Then oneDrivePath = Environ("OneDriveConsumer")
    
        'パターン文字列指定
        cloudPattern = "https://d.docs.live.net/[^/$]+" '個人用
    End If
    
    'パターン文字列の範囲をOneDrive用フォルダーのパスに置換
    With CreateObject("VBScript.RegExp")
        .Pattern = cloudPattern
        .IgnoreCase = True
        ' url="https://会社名-my.sharepoint.com/personal/ユーザー名_domain_com/Documents" + "/ファルダ名"
        .Global = False
        localPath = .Replace(url, oneDrivePath)
        ' urlのPattern部分（https～/Documents）を、oneDrivePathに置換
    End With

    '残る「/」をセパレーターに変換
    localPath = Replace(localPath, "/", Application.PathSeparator)
    
    ' 出力
    getFolderPathFromBook = localPath

End Function

'*******************************
'* ブックからフルパスを取得。ファイル名含む。One Drive対応。
'* 戻り値：ブックのフルパス
'* wb：開いているWorkbookを指定
Function getFullPathFromBook(ByVal wb As Workbook) As String
    getFullPathFromBook = getFolderPathFromBook(wb) & "\" & wb.Name
End Function

Private Sub test()
    MsgBox getFolderPathFromBook(ActiveWorkbook) _
        & vbCrLf & getFullPathFromBook(ActiveWorkbook)
End Sub

Function getFolderPathFromBook(ByVal wb As Workbook) As String

Const Cns_OneDrive法人パターン As String = "*my.sharepoint.com*"

cloudPattern = "https://.+my.sharepoint.com/personal/[^/$]+/Documents"

cloudPattern = "https://d.docs.live.net/[^/$]+"

With CreateObject("VBScript.RegExp")
    .Pattern = cloudPattern
    .IgnoreCase = True
    .Global = False
    localPath = .Replace(url, oneDrivePath)
End With

Function getFullPathFromBook(ByVal wb As Workbook) As String
    getFullPathFromBook = getFolderPathFromBook(wb) & "\" & wb.Name
End Function