excelvbaonedrive

Excel's fullname property with OneDrive


If I want to use the open Workbook object to get the fullname of an Excel file after saving it, but that file has been synchronized to OneDrive, I get a "https" address instead of a local one, which other programs cannot interpret.
How do I get the local filename of a file like this?

Example:
Save a file to "C:\Users\user\OneDrive - Company\Documents".
OneDrive does its synchronization.
Querying Workbook.FullName now shows as "https://..."


Solution

  • Universal Solution & Meta-Analysis of All Solutions

    TLDR:

    Background

    @Cristian Buse and I worked extensively on this problem after testing all other solutions available online and finding none of them universally accurate.

    In the end, both of us created independent solutions:


    The Solutions

    NOTES:

    Solution 1 - Library

    Import this library: VBA-FileTools from GitHub into your project. Getting the local name of your workbook is then as easy as:

    GetLocalPath(ThisWorkbook.FullName)
    

    Notes:
    Full Mac support was added to this solution on Apr 5, 2023.
    Support for OneDrive version 23.184.0903.0001 was added to this solution on Sep 25, 2023.

    Solution 2 - Standalone Function

    Copy this function, from GitHub Gist into any standard code module.

    Getting the local name of your workbook now works in the same way as with Solution 1:

    GetLocalPath(ThisWorkbook.FullName)
    

    Notes:
    Partial Mac support was added to this solution on Dec 20, 2022, and full support on Mar 20, 2023.
    Support for OneDrive version 23.184.0903.0001 was added to this solution on Oct 2, 2023.
    This function also offers some optional parameters, but they should almost never be needed. (See Gist for more information)

    You can also copy the function directly from here: Shortened because of StackOverflows 30 000 character answer length limit.

    'Function for converting a OneDrive URL to the corresponding local path
    'Algorithmically shortened code from here: 
    'https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
    'Author: Guido Witt-Dörring
    Public Function GetLocalPath$(ByVal path$, Optional ByVal returnAll As Boolean = False, Optional ByVal preferredMountPointOwner$ = "", Optional ByVal rebuildCache As Boolean = False)
    #If Mac Then
    Const dp& = 70
    Const ch$ = ".849C9593-D756-4E56-8D6E-42412F2A707B"
    Const er As Boolean = True
    Const ab$ = "/"
    #Else
    Const ab$ = "\"
    Const er As Boolean = False
    #End If
    Const be$ = "GetLocalPath"
    Const es& = 53
    Const fl& = 7
    Const fm& = 457
    Const fn& = 325
    Static ac As collection, et As Date
    If Not Left(path, 8) = "https://" Then GetLocalPath = path: Exit Function
    Dim r$, h$, b$, e
    Dim dq$: dq = LCase$(preferredMountPointOwner)
    If Not ac Is Nothing And Not rebuildCache Then
    Dim bn As collection: Set bn = New collection
    For Each e In ac
    h = e(0): r = e(1)
    If InStr(1, path, r, vbTextCompare) = 1 Then bn.Add Key:=e(2), Item:=Replace(Replace(path, r, h, , 1), "/", ab)
    Next e
    If bn.count > 0 Then
    If returnAll Then
    For Each e In bn: b = b & "//" & e: Next e
    GetLocalPath = Mid$(b, 3): Exit Function
    End If
    On Error Resume Next: GetLocalPath = bn(dq): On Error GoTo 0
    If GetLocalPath <> "" Then Exit Function
    GetLocalPath = bn(1): Exit Function
    End If
    GetLocalPath = path
    End If
    Dim bg As collection: Set bg = New collection
    Dim ax, ds$
    #If Mac Then
    Dim ci$, dt As Boolean
    b = Environ("HOME")
    ds = b & "/Library/Application Support/Microsoft/Office/CLP/"
    b = Left$(b, InStrRev(b, "/Library/Containers/", , vbBinaryCompare))
    bg.Add b & "Library/Containers/com.microsoft.OneDrive-mac/Data/Library/Application Support/OneDrive/settings/"
    bg.Add b & "Library/Application Support/OneDrive/settings/"
    ci = b & "Library/CloudStorage/"
    #Else
    bg.Add Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
    ds = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
    #End If
    Dim a&
    #If Mac Then
    Dim ay(): ReDim ay(1 To bg.count * 11 + 1)
    For Each ax In bg
    For a = a + 1 To a + 9
    ay(a) = ax & "Business" & a Mod 11
    Next a
    ay(a) = ax: a = a + 1
    ay(a) = ax & "Personal"
    Next ax
    ay(a + 1) = ci
    Dim du As Boolean
    du = getsetting("GetLocalPath", "AccessRequestInfoMsg", "Displayed", "False") = "True"
    If Not du Then MsgBox "The current VBA Project requires access to the OneDrive settings files to translate a OneDrive URL to the local path of the locally synchronized file/folder on your Mac. Because these files are located outside of Excels sandbox, file-access must be granted explicitly. Please approve the access requests following this message.", vbInformation
    If Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be
    #End If
    Dim cz As collection: Set cz = New collection
    For Each ax In bg
    Dim g$: g = Dir(ax, vbDirectory)
    Do Until g = vbNullString
    If g = "Personal" Or g Like "Business#" Then cz.Add Item:=ax & g & ab
    g = Dir(, vbDirectory)
    Loop
    Next ax
    If Not ac Is Nothing Or er Then
    Dim bf As collection: Set bf = New collection
    Dim f
    For Each f In cz
    Dim t$: t = iif(f Like "*" & ab & "Personal" & ab, "????????????*", "????????-????-????-????-????????????")
    Dim p$: p = Dir(f, vbNormal)
    Do Until p = vbNullString
    If p Like t & ".ini" Or p Like t & ".dat" Or p Like "ClientPolicy*.ini" Or StrComp(p, "GroupFolders.ini", vbTextCompare) = 0 Or StrComp(p, "global.ini", vbTextCompare) = 0 Or StrComp(p, "SyncEngineDatabase.db", vbTextCompare) = 0 Then bf.Add Item:=f & p
    p = Dir
    Loop
    Next f
    End If
    If Not ac Is Nothing And Not rebuildCache Then
    Dim at
    For Each at In bf
    If FileDateTime(at) > et Then rebuildCache = True: Exit For
    Next at
    If Not rebuildCache Then Exit Function
    End If
    Dim c&, am$, d() As Byte, i&, q&
    Dim bp&, au() As Byte, ck$
    Dim l() As Byte, ao$, aj() As Byte
    Dim az() As Byte, bq$, av&
    Dim y&, dx&, dy&
    et = Now()
    #If Mac Then
    Dim z As collection: Set z = New collection
    g = Dir(ci, vbDirectory)
    Do Until g = vbNullString
    If g Like "OneDrive*" Then
    dt = True
    f = ci & g & ab
    at = ci & g & ab & ch
    z.Add Item:=f
    bf.Add Item:=f
    bf.Add Item:=at
    End If
    g = Dir(, vbDirectory)
    Loop
    If ac Is Nothing Then
    Dim da
    If bf.count > 0 Then
    ReDim da(1 To bf.count)
    For a = 1 To UBound(da): da(a) = bf(a): Next a
    If Not GrantAccessToMultipleFiles(da) Then Err.Raise dp, be
    End If
    End If
    If dt Then
    For a = z.count To 1 Step -1
    Dim br&: br = 0
    On Error Resume Next
    br = GetAttr(z(a) & ch)
    Dim bs As Boolean: bs = False
    If Err.Number = 0 Then bs = Not CBool(br And vbDirectory)
    On Error GoTo 0
    If Not bs Then
    g = Dir(z(a), vbDirectory)
    Do Until g = vbNullString
    If Not g Like ".Trash*" And g <> "Icon" Then
    z.Add z(a) & g & ab
    z.Add z(a) & g & ab & ch, z(a) & g & ab
    End If
    g = Dir(, vbDirectory)
    Loop
    z.Remove a
    End If
    Next a
    If z.count > 0 Then
    ReDim ay(1 To z.count)
    For a = 1 To z.count: ay(a) = z(a): Next a
    If Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be
    End If
    On Error Resume Next
    For a = z.count To 1 Step -1
    z.Remove z(a)
    Next a
    On Error GoTo 0
    Dim dz As collection
    Set dz = New collection
    For Each f In z
    br = 0
    On Error Resume Next
    br = GetAttr(f & ch)
    bs = False
    If Err.Number = 0 Then bs = Not CBool(br And vbDirectory)
    On Error GoTo 0
    If bs Then
    c = FreeFile(): b = "": at = f & ch
    Dim ea As Boolean: ea = False
    On Error GoTo ReadFailed
    Open at For Binary Access Read As #c
    ReDim d(0 To LOF(c)): Get c, , d: b = d
    ea = True
    ReadFailed: On Error GoTo -1
    Close #c: c = 0
    On Error GoTo 0
    If ea Then
    au = b
    If LenB(b) > 0 Then
    ReDim l(0 To LenB(b) * 2 - 1): q = 0
    For i = LBound(au) To UBound(au)
    l(q) = au(i): q = q + 2
    Next i
    b = l
    Else: b = vbNullString
    End If
    Else
    at = MacScript("return path to startup disk as string") & Replace(Mid$(at, 2), ab, ":")
    b = MacScript("return read file """ & at & """ as string")
    End If
    If InStr(1, b, """guid"" : """, vbBinaryCompare) Then
    b = Split(b, """guid"" : """)(1)
    am = Left$(b, InStr(1, b, """", 0) - 1)
    dz.Add Key:=am, Item:=VBA.Array(am, Left$(f, Len(f) - 1))
    Else
    Debug.Print "Warning, empty syncIDFile encountered!"
    End If
    End If
    Next f
    End If
    If Not du Then savesetting "GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"
    #End If
    Dim j, w$(), s&, cl$
    Dim db$, dc$, cm$, bj$
    Dim aa$, ak$, aq$
    Dim bx$, ew$, by As Boolean
    Dim bz$, ca$, dd$, ex$
    Dim ey$, af$, ez$
    Dim fa$: fa = chrb$(2)
    Dim eb As String * 4: MidB$(eb, 1) = chrb$(1)
    Dim ec$: ec = chrb$(0)
    #If Mac Then
    Const ed$ = vbNullChar & vbNullChar
    #Else
    Const ed$ = vbNullChar
    #End If
    Dim cn As collection, fd As Date
    Set cn = New collection
    Set ac = New collection
    For Each f In cz
    g = Mid$(f, InStrRev(f, ab, Len(f) - 1, 0) + 1)
    g = Left$(g, Len(g) - 1)
    If Dir(f & "global.ini", vbNormal) = "" Then GoTo NextFolder
    c = FreeFile()
    Open f & "global.ini" For Binary Access Read As #c
    ReDim d(0 To LOF(c)): Get c, , d
    Close #c: c = 0
    #If Mac Then
    bq = d: GoSub DecodeUTF8
    d = ao
    #End If
    For Each j In Split(d, vbNewLine)
    If j Like "cid = *" Then t = Mid$(j, 7): Exit For
    Next j
    If t = vbNullString Then GoTo NextFolder
    If (Dir(f & t & ".ini") = vbNullString Or (Dir(f & "SyncEngineDatabase.db") = vbNullString And Dir(f & t & ".dat") = vbNullString)) Then GoTo NextFolder
    If g Like "Business#" Then
    bx = Replace(Space$(32), " ", "[a-f0-9]") & "*"
    ElseIf g = "Personal" Then
    bx = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"
    End If
    p = Dir(ds, vbNormal)
    Do Until p = vbNullString
    a = InStrRev(p, t, , vbTextCompare)
    If a > 1 And t <> vbNullString Then bj = LCase$(Left$(p, a - 2)): Exit Do
    p = Dir
    Loop
    #If Mac Then
    On Error Resume Next
    fd = cn(g)
    by = (Err.Number = 0)
    On Error GoTo 0
    If by Then
    If FileDateTime(f & t & ".ini") < fd Then
    GoTo NextFolder
    Else
    For a = ac.count To 1 Step -1
    If ac(a)(5) = g Then
    ac.Remove a
    End If
    Next a
    cn.Remove g
    cn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")
    End If
    Else
    cn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")
    End If
    #End If
    Dim ba As collection: Set ba = New collection
    p = Dir(f, vbNormal)
    Do Until p = vbNullString
    If p Like "ClientPolicy*.ini" Then
    c = FreeFile()
    Open f & p For Binary Access Read As #c
    ReDim d(0 To LOF(c)): Get c, , d
    Close #c: c = 0
    #If Mac Then
    bq = d: GoSub DecodeUTF8
    d = ao
    #End If
    ba.Add Key:=p, Item:=New collection
    For Each j In Split(d, vbNewLine)
    If InStr(1, j, " = ", vbBinaryCompare) Then
    db = Left$(j, InStr(1, j, " = ", 0) - 1)
    b = Mid$(j, InStr(1, j, " = ", 0) + 3)
    Select Case db
    Case "DavUrlNamespace"
    ba(p).Add Key:=db, Item:=b
    Case "SiteID", "IrmLibraryId", "WebID"
    b = Replace(LCase$(b), "-", "")
    If Len(b) > 3 Then b = Mid$(b, 2, Len(b) - 2)
    ba(p).Add Key:=db, Item:=b
    End Select
    End If
    Next j
    End If
    p = Dir
    Loop
    Dim x As collection: Set x = Nothing
    If Dir(f & t & ".dat") = vbNullString Then GoTo Continue
    Const fs& = 1000
    Const cp& = 255
    Dim bb&: bb = -1
    Try: On Error GoTo Catch
    Set x = New collection
    Dim cq&: cq = 1
    Dim cr As Date: cr = FileDateTime(f & t & ".dat")
    a = 0
    Do
    If FileDateTime(f & t & ".dat") > cr Then GoTo Try
    c = FreeFile
    Open f & t & ".dat" For Binary Access Read As #c
    Dim df&: df = LOF(c)
    If bb = -1 Then bb = df
    ReDim d(0 To bb + fs)
    Get c, cq, d: b = d
    Dim cs&: cs = LenB(b)
    Close #c: c = 0
    cq = cq + bb
    For e = 16 To 8 Step -8
    a = InStrB(e + 1, b, eb, 0)
    Do While a > e And a < cs - 168
    If StrComp(MidB$(b, a - e, 1), fa, 0) = 0 Then
    a = a + 8: s = InStrB(a, b, ec, 0) - a
    If s < 0 Then s = 0
    If s > 39 Then s = 39
    #If Mac Then
    ck = MidB$(b, a, s)
    GoSub DecodeANSI: ak = ao
    #Else
    ak = StrConv(MidB$(b, a, s), vbUnicode)
    #End If
    a = a + 39: s = InStrB(a, b, ec, 0) - a
    If s < 0 Then s = 0
    If s > 39 Then s = 39
    #If Mac Then
    ck = MidB$(b, a, s)
    GoSub DecodeANSI: aa = ao
    #Else
    aa = StrConv(MidB$(b, a, s), vbUnicode)
    #End If
    a = a + 121
    s = InStr(-Int(-(a - 1) / 2) + 1, b, ed, 0) * 2 - a - 1
    If s > cp * 2 Then s = cp * 2
    If s < 0 Then s = 0
    If ak Like bx And aa Like bx Then
    #If Mac Then
    Do While s Mod 4 > 0
    If s > cp * 4 Then Exit Do
    s = InStr(-Int(-(a + s) / 2) + 1, b, ed, 0) * 2 - a - 1
    Loop
    If s > cp * 4 Then s = cp * 4
    aj = MidB$(b, a, s)
    ReDim l(LBound(aj) To UBound(aj))
    i = LBound(aj): q = LBound(aj)
    Do While i < UBound(aj)
    If aj(i + 2) + aj(i + 3) = 0 Then
    l(q) = aj(i)
    l(q + 1) = aj(i + 1)
    q = q + 2
    Else
    If aj(i + 3) <> 0 Then Err.Raise fn, be
    y = aj(i + 2) * &H10000 + aj(i + 1) * &H100& + aj(i)
    bp = y - &H10000
    dy = &HD800& Or (bp \ &H400&)
    dx = &HDC00& Or (bp And &H3FF)
    l(q) = dy And &HFF&
    l(q + 1) = dy \ &H100&
    l(q + 2) = dx And &HFF&
    l(q + 3) = dx \ &H100&
    q = q + 4
    End If
    i = i + 4
    Loop
    If q > LBound(l) Then
    ReDim Preserve l(LBound(l) To q - 1)
    aq = l
    Else: aq = vbNullString
    End If
    #Else
    aq = MidB$(b, a, s)
    #End If
    x.Add VBA.Array(aa, aq), ak
    End If
    End If
    a = InStrB(a + 1, b, eb, 0)
    Loop
    If x.count > 0 Then Exit For
    Next e
    Loop Until cq >= df Or bb >= df
    GoTo Continue
    Catch:
    Select Case Err.Number
    Case fm
    x.Remove ak
    Resume
    Case Is <> fl: Err.Raise Err, be
    End Select
    If bb > &HFFFFF Then bb = bb / 2: Resume Try
    Err.Raise Err, be
    Continue:
    On Error GoTo 0
    If Not x Is Nothing Then GoTo SkipDbFile
    c = FreeFile()
    Open f & "SyncEngineDatabase.db" For Binary Access Read As #c
    cs = LOF(c)
    If cs = 0 Then GoTo CloseFile
    Dim ee$: ee = chrw$(&H808)
    Const fx& = 8
    Const fy& = -3
    Const fg As Byte = 9
    Const fh& = 6
    Const fz& = &H16
    Const ga& = &H15
    Const cc& = -16
    Const dj& = -15
    Const ef& = &H100000
    Dim bk&, cd&, bc&
    Dim ag(1 To 4) As Byte
    Dim an$, dk$
    Dim eg&
    Dim eh&
    Dim ei&, dl&
    Dim ej As Byte, ek As Byte
    Dim el As Boolean
    cr = 0
    ReDim d(1 To ef)
    Do
    a = 0
    If FileDateTime(f & "SyncEngineDatabase.db") > cr Then
    Set x = New collection
    Dim dm As collection: Set dm = New collection
    cr = FileDateTime(f & "SyncEngineDatabase.db")
    bk = 1
    an = vbNullString
    End If
    If LenB(an) > 0 Then
    aq = MidB$(b, eg, eh)
    End If
    Get c, bk, d
    b = d
    a = InStrB(1 - cc, b, ee, vbBinaryCompare)
    dl = 0
    Do While a > 0
    If a + cc - 2 > dl And LenB(an) > 0 Then
    If dl > 0 Then
    aq = MidB$(b, eg, eh)
    End If
    bq = aq: GoSub DecodeUTF8
    aq = ao
    On Error Resume Next
    x.Add VBA.Array(dk, aq), an
    If Err.Number <> 0 Then
    If dm(an) < ek Then
    If x(an)(1) <> aq Or x(an)(0) <> dk Then
    x.Remove an
    dm.Remove an
    x.Add VBA.Array(dk, aq), an
    End If
    End If
    End If
    dm.Add ek, an
    On Error GoTo 0
    an = vbNullString
    End If
    If d(a + fy) <> fx Then GoTo NextSig
    el = True
    If d(a + dj) = ga Then
    i = a + dj
    ElseIf d(a + cc) = fz Then
    i = a + cc
    el = False
    ElseIf d(a + dj) <= fg Then
    i = a + dj
    Else
    GoTo NextSig
    End If
    ej = d(i)
    cd = fh
    For q = 1 To 4
    If q = 1 And ej <= fg Then
    ag(q) = d(i + 2)
    Else
    ag(q) = d(i + q)
    End If
    If ag(q) < 37 Or ag(q) Mod 2 = 0 Then GoTo NextSig
    ag(q) = (ag(q) - 13) / 2
    cd = cd + ag(q)
    Next q
    If el Then
    bc = d(i + 5)
    If bc < 15 Or bc Mod 2 = 0 Then GoTo NextSig
    bc = (bc - 13) / 2
    Else
    bc = (d(i + 5) - 128) * 64 + (d(i + 6) - 13) / 2
    If bc < 1 Or d(i + 6) Mod 2 = 0 Then GoTo NextSig
    End If
    cd = cd + bc
    ei = a + cd - 1
    If ei > ef Then
    a = a - 1
    Exit Do
    End If
    i = a + fh
    #If Mac Then
    ck = MidB$(b, i, ag(1))
    GoSub DecodeANSI: ak = ao
    #Else
    ak = StrConv(MidB$(b, i, ag(1)), vbUnicode)
    #End If
    i = i + ag(1)
    aa = StrConv(MidB$(b, i, ag(2)), vbUnicode)
    #If Mac Then
    ck = MidB$(b, i, ag(2))
    GoSub DecodeANSI: aa = ao
    #Else
    aa = StrConv(MidB$(b, i, ag(2)), vbUnicode)
    #End If
    If ak Like bx And aa Like bx Then
    eg = i + ag(2) + ag(3) + ag(4)
    eh = bc
    an = Left(ak, 32)
    dk = Left(aa, 32)
    ek = ej
    dl = ei
    End If
    NextSig:
    a = InStrB(a + 1, b, ee, vbBinaryCompare)
    Loop
    If a = 0 Then
    bk = bk + ef + cc
    Else
    bk = bk + a + cc
    End If
    Loop Until bk > cs
    CloseFile:
    Close #c
    SkipDbFile:
    c = FreeFile()
    Open f & t & ".ini" For Binary Access Read As #c
    ReDim d(0 To LOF(c)): Get c, , d
    Close #c: c = 0
    #If Mac Then
    bq = d: GoSub DecodeUTF8:
    d = ao
    #End If
    Select Case True
    Case g Like "Business#"
    Dim em As collection: Set em = New collection
    dc = vbNullString
    For Each j In Split(d, vbNewLine)
    r = "": h = "": w = Split(j, """")
    Select Case Left$(j, InStr(1, j, " = ", 0) - 1)
    Case "libraryScope"
    h = w(9)
    af = h: am = Split(w(10), " ")(2)
    cl = Split(j, " ")(2)
    ew = w(3): w = Split(w(8), " ")
    bz = w(1): dd = w(2): ca = w(3)
    If dc = vbNullString And ew = "ODB" Then
    dc = h: p = "ClientPolicy.ini"
    ey = am: ez = af
    Else: p = "ClientPolicy_" & ca & bz & ".ini"
    End If
    On Error Resume Next
    r = ba(p)("DavUrlNamespace")
    On Error GoTo 0
    If r = "" Then
    For Each e In ba
    If e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then
    r = e("DavUrlNamespace"): Exit For
    End If
    Next e
    End If
    If r = vbNullString Then Err.Raise es, be
    em.Add VBA.Array(cl, r), cl
    If Not h = vbNullString Then ac.Add VBA.Array(h, r, bj, am, af, g), Key:=h
    Case "libraryFolder"
    cl = Split(j, " ")(3)
    h = w(1): af = h
    am = Split(w(4), " ")(1)
    b = vbNullString: aa = Left$(Split(j, " ")(4), 32)
    Do
    On Error Resume Next: x aa
    by = (Err.Number = 0): On Error GoTo 0
    If Not by Then Exit Do
    b = x(aa)(1) & "/" & b
    aa = x(aa)(0)
    Loop
    r = em(cl)(1) & b
    ac.Add VBA.Array(h, r, bj, am, af, g), h
    Case "AddedScope"
    cm = w(5): If cm = " " Then cm = ""
    w = Split(w(4), " "): bz = w(1)
    dd = w(2): ca = w(3): ex = w(4)
    p = "ClientPolicy_" & ca & bz & ex & ".ini"
    On Error Resume Next
    r = ba(p)("DavUrlNamespace") & cm
    On Error GoTo 0
    If r = "" Then
    For Each e In ba
    If e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then
    r = e("DavUrlNamespace") & cm
    Exit For
    End If
    Next e
    End If
    If r = vbNullString Then Err.Raise es, be
    b = vbNullString: aa = Left$(Split(j, " ")(3), 32)
    Do
    On Error Resume Next: x aa
    by = (Err.Number = 0): On Error GoTo 0
    If Not by Then Exit Do
    b = x(aa)(1) & ab & b
    aa = x(aa)(0)
    Loop
    h = dc & ab & b
    ac.Add VBA.Array(h, r, bj, ey, ez, g), h
    Case Else: Exit For
    End Select
    Next j
    Case g = "Personal"
    For Each j In Split(d, vbNewLine)
    If j Like "library = *" Then
    w = Split(j, """"): h = w(3)
    af = h: am = Split(w(4), " ")(2)
    Exit For
    End If
    Next j
    On Error Resume Next
    r = ba("ClientPolicy.ini")("DavUrlNamespace")
    On Error GoTo 0
    If h = "" Or r = "" Or t = "" Then GoTo NextFolder
    ac.Add VBA.Array(h, r & "/" & t, bj, am, af, g), Key:=h
    If Dir(f & "GroupFolders.ini") = "" Then GoTo NextFolder
    t = vbNullString: c = FreeFile()
    Open f & "GroupFolders.ini" For Binary Access Read As #c
    ReDim d(0 To LOF(c)): Get c, , d
    Close #c: c = 0
    #If Mac Then
    bq = d: GoSub DecodeUTF8
    d = ao
    #End If
    For Each j In Split(d, vbNewLine)
    If j Like "*_BaseUri = *" And t = vbNullString Then
    t = LCase$(Mid$(j, InStrRev(j, "/", , 0) + 1, InStrRev(j, "!", , 0) - InStrRev(j, "/", , 0) - 1))
    ak = Left$(j, InStr(1, j, "_", 0) - 1)
    ElseIf t <> vbNullString Then
    ac.Add VBA.Array(h & ab & x(ak)(1), r & "/" & t & "/" & Mid$(j, Len(ak) + 9), bj, am, af, g), Key:=h & ab & x(ak)(1)
    t = vbNullString: ak = vbNullString
    End If
    Next j
    End Select
    NextFolder:
    t = vbNullString: b = vbNullString: bj = vbNullString
    Next f
    Dim ce As collection: Set ce = New collection
    For Each e In ac
    h = e(0): r = e(1): af = e(4)
    If Right$(r, 1) = "/" Then r = Left$(r, Len(r) - 1)
    If Right$(h, 1) = ab Then h = Left$(h, Len(h) - 1)
    If Right$(af, 1) = ab Then af = Left$(af, Len(af) - 1)
    ce.Add VBA.Array(h, r, e(2), e(3), af), h
    Next e
    Set ac = ce
    #If Mac Then
    If dt Then
    Set ce = New collection
    For Each e In ac
    h = e(0): am = e(3): af = e(4)
    h = Replace(h, af, dz(am)(1), , 1)
    ce.Add VBA.Array(h, e(1), e(2)), h
    Next e
    Set ac = ce
    End If
    #End If
    GetLocalPath = GetLocalPath(path, returnAll, dq, False): Exit Function
    Exit Function
    DecodeUTF8:
    Const cf As Boolean = False
    Dim u&, m&, bl&
    Static cg(0 To 255) As Byte
    Static fj&(2 To 4)
    Static dn&(2 To 4)
    If cg(0) = 0 Then
    For u = &H0& To &H7F&: cg(u) = 1: Next u
    For u = &HC2& To &HDF&: cg(u) = 2: Next u
    For u = &HE0& To &HEF&: cg(u) = 3: Next u
    For u = &HF0& To &HF4&: cg(u) = 4: Next u
    For u = 2 To 4: fj(u) = (2 ^ (7 - u) - 1): Next u
    dn(2) = &H80&: dn(3) = &H800&: dn(4) = &H10000
    End If
    Dim en As Byte
    az = bq
    ReDim l(0 To (UBound(az) - LBound(az) + 1) * 2)
    m = 0
    u = LBound(az)
    Do While u <= UBound(az)
    y = az(u)
    av = cg(y)
    If av = 0 Then
    If cf Then Err.Raise 5
    GoTo insertErrChar
    ElseIf av = 1 Then
    l(m) = y
    m = m + 2
    ElseIf u + av - 1 > UBound(az) Then
    If cf Then Err.Raise 5
    GoTo insertErrChar
    Else
    y = az(u) And fj(av)
    For bl = 1 To av - 1
    en = az(u + bl)
    If (en And &HC0&) = &H80& Then
    y = (y * &H40&) + (en And &H3F)
    Else
    If cf Then Err.Raise 5
    GoTo insertErrChar
    End If
    Next bl
    If y < dn(av) Then
    If cf Then Err.Raise 5
    GoTo insertErrChar
    ElseIf y < &HD800& Then
    l(m) = CByte(y And &HFF&)
    l(m + 1) = CByte(y \ &H100&)
    m = m + 2
    ElseIf y < &HE000& Then
    If cf Then Err.Raise 5
    GoTo insertErrChar
    ElseIf y < &H10000 Then
    If y = &HFEFF& Then GoTo nextCp
    l(m) = y And &HFF&
    l(m + 1) = y \ &H100&
    m = m + 2
    ElseIf y < &H110000 Then
    bp = y - &H10000
    Dim eo&: eo = &HDC00& Or (bp And &H3FF)
    Dim ep&: ep = &HD800& Or (bp \ &H400&)
    l(m) = ep And &HFF&
    l(m + 1) = ep \ &H100&
    l(m + 2) = eo And &HFF&
    l(m + 3) = eo \ &H100&
    m = m + 4
    Else
    If cf Then Err.Raise 5
    insertErrChar: l(m) = &HFD
    l(m + 1) = &HFF
    m = m + 2
    If av = 0 Then av = 1
    End If
    End If
    nextCp: u = u + av
    Loop
    ao = MidB$(l, 1, m)
    Return
    DecodeANSI:
    au = ck
    m = UBound(au) - LBound(au) + 1
    If m > 0 Then
    ReDim l(0 To m * 2 - 1): bl = 0
    For m = LBound(au) To UBound(au)
    l(bl) = au(m): bl = bl + 2
    Next m
    ao = l
    Else
    ao = vbNullString
    End If
    Return
    End Function
    

    How Do the Solutions Work?

    Both solutions get all of the required information for translating the OneDrive URL to a local path from the OneDrive settings files inside of the directory %localappdata%\Microsoft\OneDrive\settings\....

    The following files may be read:

    (Wildcards: * - zero or more characters; ? - one character)

    ????????????????.dat
    ????????????????.ini
    global.ini
    GroupFolders.ini
    ????????-????-????-????-????????????.dat
    ????????-????-????-????-????????????.ini
    ClientPolicy*.ini
    SyncEngineDatabase.db
    

    Data from all of these files is used, to create a "dictionary" of all the local mount points on your pc, and their corresponding OneDrive URL-root. For example, for your personal OneDrive, such a local mount point could look like this: C:\Users\Username\OneDrive, and the corresponding URL-root could look like this: https://d.docs.live.net/f9d8c1184686d493.

    For more information on how exactly the dictionary is built and used, please refer to the extensive comments above the code in the Gist of the standalone function and the resources linked there.


    Testing and Comparison of Solutions

    I conducted extensive testing of all solutions I could find online. A selection of these tests will be presented here.

    This is a list of some of the tested solutions:

    Nr. Author Solution Tests passed
    1 Koen Rijnsent https://stackoverflow.com/a/71753164/12287457 0/46
    2 Cooz2, adapted for Excel by LucasHol https://social.msdn.microsoft.com/Forums/office/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive 0/46
    3 Julio Garcia https://stackoverflow.com/a/74360506/12287457 0/46
    4 Claude https://stackoverflow.com/a/64657459/12287457 0/46
    5 Variatus https://stackoverflow.com/a/68568909/12287457 0/46
    6 MatChrupczalski https://social.msdn.microsoft.com/Forums/office/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive 1/46
    7 Caio Silva https://stackoverflow.com/a/67318424/12287457 and https://stackoverflow.com/a/67326133/12287457 2/46
    8 Alain YARDIM https://stackoverflow.com/a/65967886/12287457 2/46
    9 tsdn https://stackoverflow.com/a/56326922/12287457 2/46
    10 Peter G. Schild https://stackoverflow.com/a/60990170/12287457 2/46
    11 TWMIC https://stackoverflow.com/a/64591370/12287457 3/46
    12 Horoman https://stackoverflow.com/a/60921115/12287457 4/46
    13 Philip Swannell https://stackoverflow.com/a/54182663/12287457 4/46
    14 RMK https://stackoverflow.com/a/67697487/12287457 5/46
    15 beerockxs https://stackoverflow.com/a/67582367/12287457 5/46
    16 Virtuoso https://stackoverflow.com/a/33935405/12287457 5/46
    17 COG https://stackoverflow.com/a/51316641/12287457 5/46
    18 mohnston https://stackoverflow.com/a/68569925/12287457 5/46
    19 Tomoaki Tsuruya (鶴谷 朋亮) https://tsurutoro.com/vba-trouble2/ 5/46
    20 Greedo https://gist.github.com/Greedquest/ 52eaccd25814b84cc62cbeab9574d7a3 6/45
    21 Christoph Ackermann https://stackoverflow.com/a/62742852/12287457 6/46
    22 Schoentalegg https://stackoverflow.com/a/57040668/12287457 6/46
    23 Erlandsen Data Consulting https://www.erlandsendata.no/?t=vbatips&p=4079 7/46
    24 Kurobako (黒箱) https://kuroihako.com/vba/onedriveurltolocalpath/ 7/46
    25 Tim Williams https://stackoverflow.com/a/70610729/12287457 8/46
    26 Erik van der Neut https://stackoverflow.com/a/72709568/12287457 8/46
    27 Ricardo Diaz https://stackoverflow.com/a/65605893/12287457 9/46
    28 Iksi https://stackoverflow.com/a/68963896/12287457 11/46
    29 Gustav Brock, Cactus Data ApS https://stackoverflow.com/a/70521246/12287457 11/46
    30 Ricardo Gerbaudo https://stackoverflow.com/a/69929678/12287457 14/46
    31 Guido Witt-Dörring Short solution https://stackoverflow.com/a/72736924/12287457 24/46
    32 Ion Cristian Buse https://github.com/cristianbuse/VBA-FileTools 46/46
    33 Guido Witt-Dörring Universal Solution https://gist.github.com/guwidoe/ 038398b6be1b16c458365716a921814d 46/46

    Each line in the table in the below image represents one solution in the above table and they can be correlated using the solution number.
    Likewise, each column represents a test case, they can be correlated to this test-table by using the test-number. Unfortunately, Stack Overflow doesn't allow answers long enough to include the table of test cases directly in this post.

    Test result data

    All of this testing was done on Windows. On macOS, every solution except for Nr 32 and Nr 33 would pass 0/46 tests. The solutions presented in this post (#32 and #33) also pass every test on macOS.

    Most solutions pass very few tests. Many of these tests are relatively difficult to solve, some are absolute edge cases, such as tests Nr 41 to 46, that test how a solution deals with OneDrive folders that are synced to multiple different local paths, which can only happen if multiple Business OneDrive accounts are logged in on the same PC and even then needs some special setup. (More information on that can be found here in Thread 2)

    Test Nr 22 contains various Unicode emoji characters in some folder names, this is why many solutions fail with error here.

    If you have another different solution you would like me to test, let me know and I'll add it to this section.