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://..."
TLDR:
For the solution, skip to the section The Solutions
For the meta-analysis, skip to the section Testing and comparison of solutions
@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:
@Cristian Buse developed his solution as part of one of his excellent VBA Libraries, to be specific, the Library VBA-FileTools. This library also provides a bunch of other very useful functionalities.
My solution comes in the form of a standalone function without any dependencies. This is useful if this problem occurs in a small project where no additional functionality is required. Because implementing the desired universal functionality is complex, it is very long and convoluted for a single procedure.
NOTES:
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.
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 shortened function (because of StackOverflows 30 000 character answer length limit) directly from here:
'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 dr& = 70, ck$ = ".849C9593-D756-4E56-8D6E-42412F2A707B", ew As Boolean = True, ab$ = "/"
#Else
Const ab$ = "\", ew As Boolean = False
#End If
Const ax$ = "GetLocalPath", ex& = 53, fr& = 7, fs& = 457, ey& = 325
Static ac As Collection, ez As Date
If Not Left$(path, 8) = "https://" Then GetLocalPath = path: Exit Function
Dim r$, i$, b$, d
Dim ds$: ds = LCase$(preferredMountPointOwner)
If Not ac Is Nothing And Not rebuildCache Then
Dim bp As Collection: Set bp = New Collection
For Each d In ac
i = d(0): r = d(1)
If InStr(1, path, r, 1) = 1 Then bp.Add Key:=d(2), Item:=Replace(Replace(path, r, i, , 1), "/", ab)
Next d
If bp.count > 0 Then
If returnAll Then
For Each d In bp: b = b & "//" & d: Next d
GetLocalPath = Mid$(b, 3): Exit Function
End If
On Error Resume Next: GetLocalPath = bp(ds): On Error GoTo 0
If GetLocalPath <> "" Then Exit Function
GetLocalPath = bp(1): Exit Function
End If
GetLocalPath = path
End If
Dim bg As Collection: Set bg = New Collection
Dim ay, du$
#If Mac Then
Dim cl$, dv As Boolean
b = Environ("HOME")
du = b & "/Library/Application Support/Microsoft/Office/CLP/"
b = Left$(b, InStrRev(b, "/Library/Containers/", , 0))
bg.Add b & "Library/Containers/com.microsoft.OneDrive-mac/Data/Library/Application Support/OneDrive/settings/"
bg.Add b & "Library/Application Support/OneDrive/settings/"
cl = b & "Library/CloudStorage/"
#Else
bg.Add Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
du = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
#End If
Dim a&
#If Mac Then
Dim az() As Variant: ReDim az(1 To bg.count * 11 + 1)
For Each ay In bg
For a = a + 1 To a + 9
az(a) = ay & "Business" & a Mod 11
Next a
az(a) = ay: a = a + 1
az(a) = ay & "Personal"
Next ay
az(a + 1) = cl
Dim dw As Boolean
dw = getsetting("GetLocalPath", "AccessRequestInfoMsg", "Displayed", "False") = "True"
If Not dw 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(az) Then Err.Raise dr, ax
#End If
Dim db As Collection: Set db = New Collection
For Each ay In bg
Dim h$: h = Dir(ay, 16)
Do Until h = ""
If h = "Personal" Or h Like "Business#" Then db.Add Item:=ay & h & ab
h = Dir(, 16)
Loop
Next ay
If Not ac Is Nothing Or ew Then
Dim bf As Collection: Set bf = New Collection
Dim g
For Each g In db
Dim t$: t = IIf(g Like "*" & ab & "Personal" & ab, "????????????*", "????????-????-????-????-????????????")
Dim p$: p = Dir(g, vbNormal)
Do Until p = ""
If p Like t & ".ini" Or p Like t & ".dat" Or p Like "ClientPolicy*.ini" Or StrComp(p, "GroupFolders.ini", 1) = 0 Or StrComp(p, "global.ini", 1) = 0 Or StrComp(p, "SyncEngineDatabase.db", 1) = 0 Then bf.Add Item:=g & p
p = Dir
Loop
Next g
End If
If Not ac Is Nothing And Not rebuildCache Then
Dim au
For Each au In bf
If FileDateTime(au) > ez Then rebuildCache = True: Exit For
Next au
If Not rebuildCache Then Exit Function
End If
Dim f&, am$, e() As Byte, j&, q&, bs&, av() As Byte, cn$, n() As Byte, ao$, ak() As Byte, ba() As Byte, bt$, aw&, y&, dz&, ea&
ez = Now()
#If Mac Then
Dim z As Collection: Set z = New Collection
h = Dir(cl, 16)
Do Until h = ""
If h Like "OneDrive*" Then
dv = True
g = cl & h & ab
au = cl & h & ab & ck
z.Add Item:=g
bf.Add Item:=g
bf.Add Item:=au
End If
h = Dir(, 16)
Loop
If ac Is Nothing Then
Dim dc
If bf.count > 0 Then
ReDim dc(1 To bf.count)
For a = 1 To UBound(dc): dc(a) = bf(a): Next a
If Not GrantAccessToMultipleFiles(dc) Then Err.Raise dr, ax
End If
End If
If dv Then
For a = z.count To 1 Step -1
Dim bu&: bu = 0
On Error Resume Next
bu = GetAttr(z(a) & ck)
Dim bv As Boolean: bv = False
If Err.Number = 0 Then bv = Not CBool(bu And 16)
On Error GoTo 0
If Not bv Then
h = Dir(z(a), 16)
Do Until h = ""
If Not h Like ".Trash*" And h <> "Icon" Then
z.Add z(a) & h & ab
z.Add z(a) & h & ab & ck, z(a) & h & ab
End If
h = Dir(, 16)
Loop
z.Remove a
End If
Next a
If z.count > 0 Then
ReDim az(1 To z.count)
For a = 1 To z.count: az(a) = z(a): Next a
If Not GrantAccessToMultipleFiles(az) Then Err.Raise dr, ax
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 eb As Collection
Set eb = New Collection
For Each g In z
bu = 0
On Error Resume Next
bu = GetAttr(g & ck)
bv = False
If Err.Number = 0 Then bv = Not CBool(bu And 16)
On Error GoTo 0
If bv Then
f = FreeFile(): b = "": au = g & ck
Dim ec As Boolean: ec = False
On Error GoTo ReadFailed
Open au For Binary Access Read As #f
ReDim e(0 To LOF(f)): Get f, , e: b = e
ec = True
ReadFailed: On Error GoTo -1
Close #f: f = 0
On Error GoTo 0
If ec Then
av = b
If LenB(b) > 0 Then
ReDim n(0 To LenB(b) * 2 - 1): q = 0
For j = LBound(av) To UBound(av)
n(q) = av(j): q = q + 2
Next j
b = n
Else: b = ""
End If
Else
au = MacScript("return path to startup disk as string") & Replace(Mid$(au, 2), ab, ":")
b = MacScript("return read file """ & au & """ as string")
End If
If InStr(1, b, """guid"" : """, 0) Then
b = Split(b, """guid"" : """)(1)
am = Left$(b, InStr(1, b, """", 0) - 1)
eb.Add Key:=am, Item:=VBA.Array(am, Left$(g, Len(g) - 1))
Else
Debug.Print "Warning, empty syncIDFile encountered!"
End If
End If
Next g
End If
If Not dw Then savesetting "GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"
#End If
Dim c, w$(), s&, co$, bk$, dd$, cp$, bl$, aa$, al$, at$, bz$, fx$, ca As Boolean, cb$, cc$, de$, fc$, fd$, ag$, fe$
Dim ff$: ff = ChrB$(2)
Dim ed As String * 4: MidB$(ed, 1) = ChrB$(1)
Dim ee$: ee = ChrB$(0)
#If Mac Then
Const ef$ = vbNullChar & vbNullChar
#Else
Const ef$ = vbNullChar
#End If
Dim cq As Collection, fi As Date
Set cq = New Collection
Set ac = New Collection
For Each g In db
h = Mid$(g, InStrRev(g, ab, Len(g) - 1, 0) + 1)
h = Left$(h, Len(h) - 1)
If Dir(g & "global.ini", vbNormal) = "" Then GoTo NextFolder
f = FreeFile()
Open g & "global.ini" For Binary Access Read As #f
ReDim e(0 To LOF(f)): Get f, , e
Close #f: f = 0
#If Mac Then
bt = e: GoSub DecodeUTF8
e = ao
#End If
For Each c In Split(e, vbNewLine)
If c Like "cid = *" Then t = Mid$(c, 7): Exit For
Next c
If t = "" Then GoTo NextFolder
If (Dir(g & t & ".ini") = "" Or (Dir(g & "SyncEngineDatabase.db") = "" And Dir(g & t & ".dat") = "")) Then GoTo NextFolder
If h Like "Business#" Then
bz = Replace(Space$(32), " ", "[a-f0-9]") & "*"
ElseIf h = "Personal" Then
bz = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"
End If
p = Dir(du, vbNormal)
Do Until p = ""
a = InStrRev(p, t, , 1)
If a > 1 And t <> "" Then bl = LCase$(Left$(p, a - 2)): Exit Do
p = Dir
Loop
#If Mac Then
On Error Resume Next
fi = cq(h)
ca = (Err.Number = 0)
On Error GoTo 0
If ca Then
If FileDateTime(g & t & ".ini") < fi Then
GoTo NextFolder
Else
For a = ac.count To 1 Step -1
If ac(a)(5) = h Then
ac.Remove a
End If
Next a
cq.Remove h
cq.Add Key:=h, Item:=FileDateTime(g & t & ".ini")
End If
Else
cq.Add Key:=h, Item:=FileDateTime(g & t & ".ini")
End If
#End If
Dim bb As Collection: Set bb = New Collection
p = Dir(g, vbNormal)
Do Until p = ""
If p Like "ClientPolicy*.ini" Then
f = FreeFile()
Open g & p For Binary Access Read As #f
ReDim e(0 To LOF(f)): Get f, , e
Close #f: f = 0
#If Mac Then
bt = e: GoSub DecodeUTF8
e = ao
#End If
bb.Add Key:=p, Item:=New Collection
For Each c In Split(e, vbNewLine)
If InStr(1, c, " = ", 0) Then
bk = Left$(c, InStr(1, c, " = ", 0) - 1)
b = Mid$(c, InStr(1, c, " = ", 0) + 3)
Select Case bk
Case "DavUrlNamespace"
bb(p).Add Key:=bk, Item:=b
Case "SiteID", "IrmLibraryId", "WebID"
b = Replace(LCase$(b), "-", "")
If Len(b) > 3 Then b = Mid$(b, 2, Len(b) - 2)
bb(p).Add Key:=bk, Item:=b
End Select
End If
Next c
End If
p = Dir
Loop
Dim x As Collection: Set x = Nothing
If Dir(g & t & ".dat") = "" Then GoTo Continue
Const fz& = 1000
Const cs& = 255
Dim bc&: bc = -1
Try: On Error GoTo Catch
Set x = New Collection
Dim ct&: ct = 1
Dim cu As Date: cu = FileDateTime(g & t & ".dat")
a = 0
Do
If FileDateTime(g & t & ".dat") > cu Then GoTo Try
f = FreeFile
Open g & t & ".dat" For Binary Access Read As #f
Dim dg&: dg = LOF(f)
If bc = -1 Then bc = dg
ReDim e(0 To bc + fz)
Get f, ct, e: b = e
Dim cv&: cv = LenB(b)
Close #f: f = 0
ct = ct + bc
For d = 16 To 8 Step -8
a = InStrB(d + 1, b, ed, 0)
Do While a > d And a < cv - 168
If StrComp(MidB$(b, a - d, 1), ff, 0) = 0 Then
a = a + 8: s = InStrB(a, b, ee, 0) - a
If s < 0 Then s = 0
If s > 39 Then s = 39
#If Mac Then
cn = MidB$(b, a, s)
GoSub DecodeANSI: al = ao
#Else
al = StrConv(MidB$(b, a, s), 64)
#End If
a = a + 39: s = InStrB(a, b, ee, 0) - a
If s < 0 Then s = 0
If s > 39 Then s = 39
#If Mac Then
cn = MidB$(b, a, s)
GoSub DecodeANSI: aa = ao
#Else
aa = StrConv(MidB$(b, a, s), 64)
#End If
a = a + 121
s = InStr(-Int(-(a - 1) / 2) + 1, b, ef, 0) * 2 - a - 1
If s > cs * 2 Then s = cs * 2
If s < 0 Then s = 0
If al Like bz And aa Like bz Then
#If Mac Then
Do While s Mod 4 > 0
If s > cs * 4 Then Exit Do
s = InStr(-Int(-(a + s) / 2) + 1, b, ef, 0) * 2 - a - 1
Loop
If s > cs * 4 Then s = cs * 4
ak = MidB$(b, a, s)
ReDim n(LBound(ak) To UBound(ak))
j = LBound(ak): q = LBound(ak)
Do While j < UBound(ak)
If ak(j + 2) + ak(j + 3) = 0 Then
n(q) = ak(j)
n(q + 1) = ak(j + 1)
q = q + 2
Else
If ak(j + 3) <> 0 Then Err.Raise ey, ax
y = ak(j + 2) * &H10000 + ak(j + 1) * &H100& + ak(j)
bs = y - &H10000
ea = &HD800& Or (bs \ &H400&)
dz = &HDC00& Or (bs And &H3FF)
n(q) = ea And &HFF&
n(q + 1) = ea \ &H100&
n(q + 2) = dz And &HFF&
n(q + 3) = dz \ &H100&
q = q + 4
End If
j = j + 4
Loop
If q > LBound(n) Then
ReDim Preserve n(LBound(n) To q - 1)
at = n
Else: at = ""
End If
#Else
at = MidB$(b, a, s)
#End If
x.Add VBA.Array(aa, at), al
End If
End If
a = InStrB(a + 1, b, ed, 0)
Loop
If x.count > 0 Then Exit For
Next d
Loop Until ct >= dg Or bc >= dg
GoTo Continue
Catch:
Select Case Err.Number
Case fs
x.Remove al
Resume
Case Is <> fr: Err.Raise Err, ax
End Select
If bc > &HFFFFF Then bc = bc / 2: Resume Try
Err.Raise Err, ax
Continue:
On Error GoTo 0
If Not x Is Nothing Then GoTo SkipDbFile
f = FreeFile()
Open g & "SyncEngineDatabase.db" For Binary Access Read As #f
cv = LOF(f)
If cv = 0 Then GoTo CloseFile
Dim eg$: eg = ChrW$(&H808)
Const gd& = 8, ge& = -3, fl As Byte = 9, fm& = 6, fn& = &H16, gf& = &H15, ce& = -16, cf& = -15, eh& = &H100000
Dim bm&, cg&, bd&, ah(1 To 4) As Byte, an$, dk$, ei&, ej&, ek&, dl&, el As Byte, em As Byte, en As Boolean, eo&
cu = 0
ReDim e(1 To eh)
Do
a = 0
If FileDateTime(g & "SyncEngineDatabase.db") > cu Then
Set x = New Collection
Dim dm As Collection: Set dm = New Collection
cu = FileDateTime(g & "SyncEngineDatabase.db")
bm = 1
an = ""
End If
If LenB(an) > 0 Then
at = MidB$(b, ei, ej)
End If
Get f, bm, e
b = e
a = InStrB(1 - ce, b, eg, 0)
dl = 0
Do While a > 0
If a + ce - 2 > dl And LenB(an) > 0 Then
If dl > 0 Then
at = MidB$(b, ei, ej)
End If
bt = at: GoSub DecodeUTF8
at = ao
On Error Resume Next
x.Add VBA.Array(dk, at), an
If Err.Number <> 0 Then
If dm(an) < em Then
If x(an)(1) <> at Or x(an)(0) <> dk Then
x.Remove an
dm.Remove an
x.Add VBA.Array(dk, at), an
End If
End If
End If
dm.Add em, an
On Error GoTo 0
an = ""
End If
If e(a + ge) <> gd Then GoTo NextSig
en = True
eo = 0
If e(a + cf) = gf Then
j = a + cf
ElseIf e(a + ce) = fn Then
j = a + ce
en = False
ElseIf e(a + cf) <= fl Then
j = a + cf
ElseIf e(a + cf) = fn Then
j = a + cf
eo = 1
Else
GoTo NextSig
End If
el = e(j)
cg = fm
For q = 1 To 4
If q = 1 And el <= fl Then
ah(q) = e(j + 2)
Else
ah(q) = e(j + q)
End If
If ah(q) < 37 Or ah(q) Mod 2 = 0 Then GoTo NextSig
ah(q) = (ah(q) - 13) / 2
cg = cg + ah(q)
Next q
If en Then
bd = e(j + 5)
If bd < 15 Or bd Mod 2 = 0 Then GoTo NextSig
bd = (bd - 13) / 2
Else
bd = (e(j + 5) - 128) * 64 + (e(j + 6) - 13) / 2
If bd < 1 Or e(j + 6) Mod 2 = 0 Then GoTo NextSig
End If
cg = cg + bd
ek = a + cg - 1
If ek > eh Then
a = a - 1
Exit Do
End If
j = a + fm + eo
#If Mac Then
cn = MidB$(b, j, ah(1))
GoSub DecodeANSI: al = ao
#Else
al = StrConv(MidB$(b, j, ah(1)), 64)
#End If
j = j + ah(1)
aa = StrConv(MidB$(b, j, ah(2)), 64)
#If Mac Then
cn = MidB$(b, j, ah(2))
GoSub DecodeANSI: aa = ao
#Else
aa = StrConv(MidB$(b, j, ah(2)), 64)
#End If
If al Like bz And aa Like bz Then
ei = j + ah(2) + ah(3) + ah(4)
ej = bd
an = Left$(al, 32)
dk = Left$(aa, 32)
em = el
dl = ek
End If
NextSig:
a = InStrB(a + 1, b, eg, 0)
Loop
If a = 0 Then
bm = bm + eh + ce
Else
bm = bm + a + ce
End If
Loop Until bm > cv
CloseFile:
Close #f
SkipDbFile:
f = FreeFile()
Open g & t & ".ini" For Binary Access Read As #f
ReDim e(0 To LOF(f)): Get f, , e
Close #f: f = 0
#If Mac Then
bt = e: GoSub DecodeUTF8:
e = ao
#End If
Dim ep As Collection: Set ep = New Collection
Dim eq
eq = VBA.Array("libraryScope", "libraryFolder", "AddedScope")
Dim dn As Collection: Set dn = New Collection
For Each d In eq
dn.Add New Collection, CStr(d)
Next d
For Each c In Split(e, vbNewLine)
If InStr(1, c, " = ", 0) = 0 Then Exit For
bk = Left$(c, InStr(1, c, " = ", 0) - 1)
Select Case bk: Case "libraryScope", "libraryFolder", "AddedScope"
dn(bk).Add c, Split(c, " ", 4, 0)(2)
End Select
Next c
For Each d In eq
Dim dp As Collection: Set dp = dn(d)
a = 0
Do Until dp.count = 0
On Error Resume Next
c = "": c = dp(CStr(a))
On Error GoTo 0
If c <> "" Then
ep.Add c
dp.Remove CStr(a)
End If
a = a + 1
Loop
Next d
If h Like "Business#" Then
Dim er As Collection: Set er = New Collection
dd = ""
For Each c In ep
r = "": i = "": w = Split(c, """")
Select Case Left$(c, InStr(1, c, " = ", 0) - 1)
Case "libraryScope"
i = w(9)
ag = i: am = Split(w(10), " ")(2)
co = Split(c, " ")(2)
fx = w(3): w = Split(w(8), " ")
cb = w(1): de = w(2): cc = w(3)
If Split(c, " ", 4, 0)(2) = "0" Then
dd = i: p = "ClientPolicy.ini"
fd = am: fe = ag
Else: p = "ClientPolicy_" & cc & cb & ".ini"
End If
On Error Resume Next
r = bb(p)("DavUrlNamespace")
On Error GoTo 0
If r = "" Then
For Each d In bb
If d("SiteID") = cb And d("WebID") = de And d("IrmLibraryId") = cc Then
r = d("DavUrlNamespace"): Exit For
End If
Next d
End If
If r = "" Then Err.Raise ex, ax
er.Add VBA.Array(co, r), co
If Not i = "" Then ac.Add VBA.Array(i, r, bl, am, ag, h), Key:=i
Case "libraryFolder"
co = Split(c, " ")(3)
i = w(1): ag = i
am = Split(w(4), " ")(1)
b = "": aa = Left$(Split(c, " ")(4), 32)
Do
On Error Resume Next: x aa
ca = (Err.Number = 0): On Error GoTo 0
If Not ca Then Exit Do
b = x(aa)(1) & "/" & b
aa = x(aa)(0)
Loop
r = er(co)(1) & b
ac.Add VBA.Array(i, r, bl, am, ag, h), i
Case "AddedScope"
If dd = "" Then Err.Raise ey, ax
cp = w(5): If cp = " " Then cp = ""
w = Split(w(4), " "): cb = w(1)
de = w(2): cc = w(3): fc = w(4)
p = "ClientPolicy_" & cc & cb & fc & ".ini"
On Error Resume Next
r = bb(p)("DavUrlNamespace") & cp
On Error GoTo 0
If r = "" Then
For Each d In bb
If d("SiteID") = cb And d("WebID") = de And d("IrmLibraryId") = cc Then
r = d("DavUrlNamespace") & cp
Exit For
End If
Next d
End If
If r = "" Then Err.Raise ex, ax
b = "": aa = Left$(Split(c, " ")(3), 32)
Do
On Error Resume Next: x aa
ca = (Err.Number = 0): On Error GoTo 0
If Not ca Then Exit Do
b = x(aa)(1) & ab & b
aa = x(aa)(0)
Loop
i = dd & ab & b
ac.Add VBA.Array(i, r, bl, fd, fe, h), i
Case Else: Exit For
End Select
Next c
ElseIf h = "Personal" Then
For Each c In Split(e, vbNewLine)
If c Like "library = *" Then
w = Split(c, """"): i = w(3)
ag = i: am = Split(w(4), " ")(2)
Exit For
End If
Next c
On Error Resume Next
r = bb("ClientPolicy.ini")("DavUrlNamespace")
On Error GoTo 0
If i = "" Or r = "" Or t = "" Then GoTo NextFolder
ac.Add VBA.Array(i, r & "/" & t, bl, am, ag, h), Key:=i
If Dir(g & "GroupFolders.ini") = "" Then GoTo NextFolder
t = "": f = FreeFile()
Open g & "GroupFolders.ini" For Binary Access Read As #f
ReDim e(0 To LOF(f)): Get f, , e
Close #f: f = 0
#If Mac Then
bt = e: GoSub DecodeUTF8
e = ao
#End If
For Each c In Split(e, vbNewLine)
If c Like "*_BaseUri = *" And t = "" Then
t = LCase$(Mid$(c, InStrRev(c, "/", , 0) + 1, InStrRev(c, "!", , 0) - InStrRev(c, "/", , 0) - 1))
al = Left$(c, InStr(1, c, "_", 0) - 1)
ElseIf t <> "" Then
ac.Add VBA.Array(i & ab & x(al)(1), r & "/" & t & "/" & Mid$(c, Len(al) + 9), bl, am, ag, h), Key:=i & ab & x(al)(1)
t = "": al = ""
End If
Next c
End If
NextFolder:
t = "": b = "": bl = ""
Next g
Dim ch As Collection: Set ch = New Collection
For Each d In ac
i = d(0): r = d(1): ag = d(4)
If Right$(r, 1) = "/" Then r = Left$(r, Len(r) - 1)
If Right$(i, 1) = ab Then i = Left$(i, Len(i) - 1)
If Right$(ag, 1) = ab Then ag = Left$(ag, Len(ag) - 1)
ch.Add VBA.Array(i, r, d(2), d(3), ag), i
Next d
Set ac = ch
#If Mac Then
If dv Then
Set ch = New Collection
For Each d In ac
i = d(0): am = d(3): ag = d(4)
i = Replace(i, ag, eb(am)(1), , 1)
ch.Add VBA.Array(i, d(1), d(2)), i
Next d
Set ac = ch
End If
#End If
GetLocalPath = GetLocalPath(path, returnAll, ds, False): Exit Function
Exit Function
DecodeUTF8:
Const ci As Boolean = False
Dim u&, o&, bn&
Static cj(0 To 255) As Byte
Static fp&(2 To 4)
Static dq&(2 To 4)
If cj(0) = 0 Then
For u = &H0& To &H7F&: cj(u) = 1: Next u
For u = &HC2& To &HDF&: cj(u) = 2: Next u
For u = &HE0& To &HEF&: cj(u) = 3: Next u
For u = &HF0& To &HF4&: cj(u) = 4: Next u
For u = 2 To 4: fp(u) = (2 ^ (7 - u) - 1): Next u
dq(2) = &H80&: dq(3) = &H800&: dq(4) = &H10000
End If
Dim es As Byte
ba = bt
ReDim n(0 To (UBound(ba) - LBound(ba) + 1) * 2)
o = 0
u = LBound(ba)
Do While u <= UBound(ba)
y = ba(u)
aw = cj(y)
If aw = 0 Then
If ci Then Err.Raise 5
GoTo insertErrChar
ElseIf aw = 1 Then
n(o) = y
o = o + 2
ElseIf u + aw - 1 > UBound(ba) Then
If ci Then Err.Raise 5
GoTo insertErrChar
Else
y = ba(u) And fp(aw)
For bn = 1 To aw - 1
es = ba(u + bn)
If (es And &HC0&) = &H80& Then
y = (y * &H40&) + (es And &H3F)
Else
If ci Then Err.Raise 5
GoTo insertErrChar
End If
Next bn
If y < dq(aw) Then
If ci Then Err.Raise 5
GoTo insertErrChar
ElseIf y < &HD800& Then
n(o) = CByte(y And &HFF&)
n(o + 1) = CByte(y \ &H100&)
o = o + 2
ElseIf y < &HE000& Then
If ci Then Err.Raise 5
GoTo insertErrChar
ElseIf y < &H10000 Then
If y = &HFEFF& Then GoTo nextCp
n(o) = y And &HFF&
n(o + 1) = y \ &H100&
o = o + 2
ElseIf y < &H110000 Then
bs = y - &H10000
Dim et&: et = &HDC00& Or (bs And &H3FF)
Dim eu&: eu = &HD800& Or (bs \ &H400&)
n(o) = eu And &HFF&
n(o + 1) = eu \ &H100&
n(o + 2) = et And &HFF&
n(o + 3) = et \ &H100&
o = o + 4
Else
If ci Then Err.Raise 5
insertErrChar: n(o) = &HFD
n(o + 1) = &HFF
o = o + 2
If aw = 0 Then aw = 1
End If
End If
nextCp: u = u + aw
Loop
ao = MidB$(n, 1, o)
Return
DecodeANSI:
av = cn
o = UBound(av) - LBound(av) + 1
If o > 0 Then
ReDim n(0 To o * 2 - 1): bn = 0
For o = LBound(av) To UBound(av)
n(bn) = av(o): bn = bn + 2
Next o
ao = n
Else
ao = ""
End If
Return
End Function
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.
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:
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.
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.
ConvertToLocalPath UDF will return a variant rather than raising an error which may make it easier to run tests. –
Adumbral =GetLocalPath(CELL("filename",$A$1)) –
Hereinafter CELL would only be applicable to the current workbook - just saying there are uses outside translating the path of the current workbook. –
Seibold GetLocalPath(UrlPath) and the code is generally very messy. If you would still want to see it, I can send you something via email. –
Hodometer %LOCALAPPDATA%\Microsoft\OneDrive\settings then follow the method in github.com/Beercow/OneDriveExplorer/blob/… (note the sql_dir is just one of the folders inside that settings dir) –
Adumbral od_ClientFolder_Records table. You can indeed reconstruct the full remote folder paths using ResourceId and ParentResourceId as you point out, which is quite trivial. –
Branca I found a thread online which contained enough information to put something simple together to solve this. I actually implemented the solution in Ruby, but this is the VBA version:
Option Explicit
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
Local_Workbook_Name = Replace(wb.FullName, "/", "\")
'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Trim OneDrive designators
For Ctr = 1 To 4
Local_Workbook_Name = Mid(Local_Workbook_Name, InStr(Local_Workbook_Name, "\") + 1)
Next
'Construct the name
Local_Workbook_Name = UserProfilePath & "\OneDrive\" & Local_Workbook_Name
Else
Local_Workbook_Name = wb.FullName
End If
End Function
Private Sub testy()
MsgBox ActiveWorkbook.FullName & vbCrLf & Local_Workbook_Name(ActiveWorkbook)
End Sub
Function testy() As String testy = Local_Workbook_Name(ActiveWorkbook) End Function Thank you! –
Suckling Horoman's version (2020-03-30) is good because it works on both private and commercial OneDrive. However it crashed on me because the line "LocalFullName = oneDrivePath & Application.PathSeparator & endFilePath" inserts a slash between oneDrivePath & endFilePath. Moreover, one should really try out paths "OneDriveCommercial" and "OneDriveConsumer" before "OneDrive". So here's the code that works for me:
Sub TestLocalFullName()
Debug.Print "URL: " & ActiveWorkbook.FullName
Debug.Print "Local: " & LocalFullName(ActiveWorkbook.FullName)
Debug.Print "Test: " & Dir(LocalFullName(ActiveWorkbook.FullName))
End Sub
Private Function LocalFullName$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive
'Reference https://mcmap.net/q/137787/-excel-39-s-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02
Dim ii&
Dim iPos&
Dim oneDrivePath$
Dim endFilePath$
If Left(fullPath, 8) = "https://" Then 'Possibly a OneDrive URL
If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then 'Commercial OneDrive
'For commercial OneDrive, path looks like "https://companyName-my.sharepoint.com/personal/userName_domain_com/Documents" & file.FullName)
'Find "/Documents" in string and replace everything before the end with OneDrive local path
iPos = InStr(1, fullPath, "/Documents") + Len("/Documents") 'find "/Documents" position in file URL
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without pointer in OneDrive. Include leading "/"
Else 'Personal OneDrive
'For personal OneDrive, path looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName
'We can get local file path by replacing "https.." up to the 4th slash, with the OneDrive local path obtained from registry
iPos = 8 'Last slash in https://
For ii = 1 To 2
iPos = InStr(iPos + 1, fullPath, "/") 'find 4th slash
Next ii
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without OneDrive root. Include leading "/"
End If
endFilePath = Replace(endFilePath, "/", Application.PathSeparator) 'Replace forward slashes with back slashes (URL type to Windows type)
For ii = 1 To 3 'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive")) 'Check possible local paths. "OneDrive" should be the last one
If 0 < Len(oneDrivePath) Then
LocalFullName = oneDrivePath & endFilePath
Exit Function 'Success (i.e. found the correct Environ parameter)
End If
Next ii
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
LocalFullName = vbNullString
Else
LocalFullName = fullPath
End If
End Function
fullPath = %OneDrive%, or equivalent, the endFilePath lines should be endFilePath = IIf(iPos = 0, "", Mid(wbPath, iPos)) –
Layla Environ result, and not just Environ("OneDriveCommercial") and Environ("OneDriveConsumer") respectively, maybe then falling back to Environ("OneDrive") if both fail. It feels like a Commercial file could overwrite a consumer one if it has the same name - even if the original link was the "https://d.docs.live.net..." style? –
Adumbral The solution presented in the following does not work in absolutely all cases, but it probably works in more than 99% of real-world scenarios. If you are looking for a solution that covers even the edge cases, please look at this universal solution.
An advantage of this solution compared to the above linked universal solution is its simplicity and therefore its lower likelihood to break because of OneDrive/Windows updates.
The function to convert the "WebPath" to a local path looks like this:
Public Function GetLocalPath(ByVal Path As String) As String
Const HKCU = &H80000001
Dim objReg As Object, rPath As String, subKeys(), subKey
Dim urlNamespace As String, mountPoint As String, secPart As String
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\." & _
"\root\default:StdRegProv")
rPath = "Software\SyncEngines\Providers\OneDrive\"
objReg.EnumKey HKCU, rPath, subKeys
For Each subKey In subKeys
objReg.GetStringValue HKCU, rPath & subKey, "UrlNamespace", urlNamespace
If InStr(Path, urlNamespace) > 0 Then
objReg.GetStringValue HKCU, rPath & subKey, "MountPoint", mountPoint
secPart = Replace(Mid(Path, Len(urlNamespace)), "/", "\")
Path = mountPoint & secPart
Do Until Dir(Path, vbDirectory) <> "" Or InStr(2, secPart, "\") = 0
secPart = Mid(secPart, InStr(2, secPart, "\"))
Path = mountPoint & secPart
Loop
Exit For
End If
Next
GetLocalPath = Path
End Function
To now get the local full name of your workbook, just use GetLocalPath(ThisWorkbook.FullName)
I have adjusted the function provided by others to account for some additional constraints:
When you share files via a team site, it's not "my.sharepoint.com/" but "sharepoint.com/" that you should use to determine if it's a commercial version.
It is better to count the slashes rather than using the position of "/Documents" because, for example in French, the document folder is called "Documents partages". It is preferable to count 4 slashes for commercial use and 2 slashes for personal use.
If the SharePoint folder added as a shortcut to OneDrive is not at the root, the local address on the hard drive does not contain parent folders on the SharePoint.
Here is the code that takes my changes into account:
Public Function AdresseLocal$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive
'Reference https://mcmap.net/q/137787/-excel-39-s-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02
Dim ii&
Dim iPos&
Dim oneDrivePath$
Dim endFilePath$
Dim NbSlash
If Left(fullPath, 8) = "https://" Then
If InStr(1, fullPath, "sharepoint.com/") <> 0 Then 'Commercial OneDrive
NbSlash = 4
Else 'Personal OneDrive
NbSlash = 2
End If
iPos = 8 'Last slash in https://
For ii = 1 To NbSlash
iPos = InStr(iPos + 1, fullPath, "/")
Next ii
endFilePath = Mid(fullPath, iPos)
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
For ii = 1 To 3
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive"))
If 0 < Len(oneDrivePath) Then Exit For
Next ii
AdresseLocal = oneDrivePath & endFilePath
While Len(Dir(AdresseLocal, vbDirectory)) = 0 And InStr(2, endFilePath, Application.PathSeparator) > 0
endFilePath = Mid(endFilePath, InStr(2, endFilePath, Application.PathSeparator))
AdresseLocal = oneDrivePath & endFilePath
Wend
Else
AdresseLocal = fullPath
End If
End Function
...which builds on the work of the different contributors.
ByVal fullPath$? Is it just ActiveWorkbook.Path? –
Weirick ThisWorkbook.Path for the parent directory, ThisWorkbook.FullName for the file itself –
Adumbral InStr(1, Mid$(path_, 9, InStr(9, path_, "/") - 9), "sharepoint", vbTextCompare) > 0 so that only the root is checked. –
Seibold It's possible to improve on Virtuoso's answer to reduce (though not eliminate) the chance that the function returns a "wrong" file location. The problem is that there are various URLs that a workbook's .FullName can be. These are three I'm aware of:
On my PC I can get the relevant local folders to map the first two URLs via the OneDriveConsumer and OneDriveCommercial environment variables, that exist in addition to the OneDrive environment variable, so the code below makes use of these. I'm not aware that it's possible to handle the "Shared with Me" files and the code below will return their https://-style location.
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
Dim i As Long, j As Long
Dim OneDrivePath As String
Dim ShortName As String
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For i = 1 To 4
ShortName = Mid(ShortName, InStr(ShortName, "\") + 1)
Next
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
For j = 1 To 3
OneDrivePath = Environ(Choose(j, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
Local_Workbook_Name = OneDrivePath & "\" & ShortName
If Dir(Local_Workbook_Name) <> "" Then
Exit Function
End If
End If
Next j
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
End If
Local_Workbook_Name = wb.FullName
End Function
Unfortunately, if files exist with identical paths within both the OneDrive folder and the OneDrive for Business folder, then the code can't distinguish between them, and may return the "wrong one". I don't have a solution for that.
Easy Fix (early 2019) - For anyone else having this issue:
OneDrive > Settings > Office: - Uncheck 'Use Office applications to sync Office files that I open'
This lets excel save the file in the typical "C:\Users[UserName]\OneDrive..." file format instead of the UNC "https:\" format.
I like the Version from TWMIC with the use of the Registry. All other Version did not work at my oneDrive for Business. There are some folders where the name is slightly different to the URL, for example in the URL are partly no spaces but in the folder there are. If it is from Teams and in the Team Name are spaces then this is a problem. Even the Folder Names from Teams are different than the URL, depending which folder level in Teams you are syncing.
The Version from TWMIC is tagged as dangerous at my work computer and i can't use it, very sad about that. So i made a Version which reads the ini File from oneDrive for Busines, if it is OneDrive for Business...
Public Function AdresseLocal$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive and loading the settings ini File of OneDrive
'Reference https://mcmap.net/q/137787/-excel-39-s-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02, Iksi 2021-08-28
Dim ScreenUpdate As Boolean
Dim ii&
Dim iPos&
Dim DatFile$, SettingsDir$, Temp$
Dim oneDrivePath$, oneDriveURL$
Dim endFilePath$
If Left(fullPath, 8) = "https://" Then
If InStr(1, fullPath, "sharepoint.com") <> 0 Then 'Commercial OneDrive
'Find the correct settings File, I'm not sure if it is always in Folder Business1, so trying to find a Folder Business and then Business1, 2 ....
'First find *.dat File, seems to be only one of that type, the correct ini File is the same Name than the dat File
DatFile = Dir(Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business\*.dat")
If DatFile <> "" Then SettingsDir = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business\"
For ii = 1 To 9
Temp = Dir(Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business" & ii & "\*.dat")
If Temp <> "" Then
If SettingsDir = "" Then
DatFile = Temp
SettingsDir = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business" & ii & "\"
Else
MsgBox "There is more than one OneDrive settings Folder!"
End If
End If
Next
'Open ini File without showing
ScreenUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Workbooks.OpenText Filename:= _
SettingsDir & Left(DatFile, Len(DatFile) - 3) & "ini" _
, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:= _
False, Comma:=False, Space:=True, Other:=False, TrailingMinusNumbers:=True
ii = 1
Do While Cells(ii, 1) = "libraryScope"
'Search the correct URL which fits to the fullPath and then search the corresponding Folder
If InStr(fullPath, Cells(ii, 9)) = 1 Then
oneDriveURL = Cells(ii, 9)
If Cells(ii, 15) <> "" Then
oneDrivePath = Cells(ii, 15)
Else
iPos = Cells(ii, 3)
Do Until Cells(ii, 1) = "libraryFolder"
ii = ii + 1
Loop
Do While Cells(ii, 1) = "libraryFolder"
If Cells(ii, 4) = iPos Then
oneDrivePath = Cells(ii, 7)
Exit Do
End If
ii = ii + 1
Loop
End If
Exit Do
End If
ii = ii + 1
Loop
ActiveWorkbook.Close False
Application.ScreenUpdating = ScreenUpdate
endFilePath = Mid(fullPath, Len(oneDriveURL) + 1)
Else 'Personal OneDrive
'For personal OneDrive, path looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName
'We can get local file path by replacing "https.." up to the 4th slash, with the OneDrive local path obtained from registry
iPos = 8 'Last slash in https://
For ii = 1 To 2
iPos = InStr(iPos + 1, fullPath, "/") 'find 4th slash
Next ii
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without OneDrive root. Include leading "/"
End If
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
If Len(oneDrivePath) <= 0 Then
For ii = 1 To 3 'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive")) 'Check possible local paths. "OneDrive" should be the last one
Next ii
End If
AdresseLocal = oneDrivePath & endFilePath
While Len(Dir(AdresseLocal, vbDirectory)) = 0 And InStr(2, endFilePath, Application.PathSeparator) > 0
endFilePath = Mid(endFilePath, InStr(2, endFilePath, Application.PathSeparator))
AdresseLocal = oneDrivePath & endFilePath
Wend
Else
AdresseLocal = fullPath
End If
End Function
For me this works great!
Very helpful, thanks. I had a similar issue, but with a folder name rather than a filename. Consequently I modified it slightly. I made it work for folder names AND filenames (doesn't have to be a workbook). In case it's helpful, code is below:
Public Function Local_Name(theName As String) As String
Dim i As Integer
Dim objShell As Object
Dim UserProfilePath As String
' Check if it looks like a OneDrive location.
If InStr(1, theName, "https://", vbTextCompare) > 0 Then
' Replace forward slashes with back slashes.
Local_Name = Replace(theName, "/", "\")
'Get environment path using vbscript.
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
' Trim OneDrive designators.
For i = 1 To 4
Local_Name = Mid(Local_Name, InStr(Local_Name, "\") + 1)
Next i
' Construct the name.
Local_Name = UserProfilePath & "\OneDrive\" & Local_Name
Else
' (must already be local).
Local_Name = theName
End If
End Function
ActiveWorkbook.path it returns C:\Users\deepstop\OneDrive\deepstop_idc_com\Documents\Shared with Noone\etc\etc, in which neither deepstop_idc_com nor Documents are in fact part of the path. –
Yurik This is really great stuff. I have run into this problem on some windows 10 machines but not others and it seems to come and go. I tried everything resetting OneDrive, changing the configuration etc. The only thing I tried that at least works on my machine is to use Fullname=CurDir & FileName, instead of FullName= activeworkbook.Path & FileName.
This returned the full local name without the https stuff and I was able to open my file ok.
Instead of using the variable ThisWorkbook.Path use Environ("OneDrive").
Option Explicit
'
Function TransferURL(wbkURL As String) As String
' Converts the URL of a OneDrive into a path.
' Returns the path's name.
Dim oFs As Object
Dim oFl As Object
Dim oSubFl As Object
Dim pos As Integer
Dim pathPart As String
Dim oneDrive As String
Dim subFl As String
Set oFs = CreateObject("Scripting.FileSystemObject")
' Check the version of OneDrive.
If VBA.InStr(1, _
VBA.UCase(wbkURL), "MY.SHAREPOINT.COM") = 0 Then
oneDrive = "OneDriveConsumer"
Else
oneDrive = "OneDriveCommercial"
End If
Set oFl = oFs.GetFolder(Environ(oneDrive))
' Iteration over OneDrive's subfolders.
For Each oSubFl In oFl.SUBFOLDERS
subFl = "/" & VBA.Mid(oSubFl.Path, _
VBA.Len(Environ(oneDrive)) + 2) & "/"
' Check if part of the URL.
If VBA.InStr(1, _
wbkURL, subFl) > 0 Then
' Determine the path after OneDrive's folder.
pos = VBA.InStr(1, _
wbkURL, subFl)
pathPart = VBA.Mid(VBA.Replace(wbkURL, "/", _
Application.PathSeparator), pos)
End If
Next
TransferURL = Environ(oneDrive) & pathPart
End Function
Call the function by:
' Check if path specification as URL.
If VBA.Left(VBA.UCase(oWbk.Path), _
5) = "HTTPS" Then
' Call ...
pathName = TransferURL(oWbk.Path)
End If
The differentiation between OneDriveConsumer and OneDriveCommercial is derived from:
Edited by MatChrupczalski Thursday, May 9, 2019 5:45 PM
I have the same problem as you. But I have solved that problem. The first I turn off OneDrive before I running the script.
you can add this script on the first script into your vba/module:
Call Shell("cmd.exe /S /C" & "%LOCALAPPDATA%\Microsoft\OneDrive\OneDrive.exe /shutdown")
and then, on your last script on your vba/module you can insert this for activate your OneDrive:
Call Shell("cmd.exe /S /C" & "start %LOCALAPPDATA%\Microsoft\OneDrive\OneDrive.exe /background")
I am using Windows10 on that script.
Option Explicit
Private coll_Locations As Collection ' using Collection but could just as easily use Dictionary
Public Const HKEY_CURRENT_USER = &H80000001
'
Public Function getOneDrv_PathFor(ByVal sPath As String, Optional ByVal sType As String = "") As String
' convert start of passed in path from URL to Local or vice.versa, (for OneDrive Sync'd folders)
' sType : if starts L(ocal) return local path, if starts U(rl) then return URL Path, else return other mode to that passed in
Dim sPathNature As String
Dim vKey As Variant
Dim Slash As String, Slash2 As String
getOneDrv_PathFor = sPath ' return unchanged if no action required or recognised
sType = UCase(Left(sType, 1))
If sType <> "L" And sType <> "U" Then sType = ""
sPathNature = IIf(Left(sPath, 4) = "http", "U", "L")
If sType <> "" And sType = sPathNature Then Exit Function ' nothing to do
If coll_Locations Is Nothing Then get_Locations
For Each vKey In coll_Locations
If InStr(1, sPath, vKey, vbTextCompare) = 1 Then
Slash = IIf(sPathNature = "U", "/", "\")
Slash2 = IIf(Slash = "/", "\", "/")
getOneDrv_PathFor = coll_Locations(vKey) & Replace(Mid(sPath, Len(vKey) + 1), Slash, Slash2)
Exit For
End If
Next
End Function
Private Sub get_Locations()
' collect possible OneDrive: URL vs Local paths
Dim oWMI As Object
Dim sRegPath As String, arrSubKeys() As Variant, vSubKey As Variant
Dim sServiceEndPointUri As String, sUserFolder As String
Set coll_Locations = New Collection
Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
sRegPath = "Software\Microsoft\OneDrive\Accounts\"
oWMI.EnumKey HKEY_CURRENT_USER, sRegPath, arrSubKeys
For Each vSubKey In arrSubKeys
oWMI.GetStringValue HKEY_CURRENT_USER, sRegPath & vSubKey, "ServiceEndPointUri", sServiceEndPointUri
oWMI.GetStringValue HKEY_CURRENT_USER, sRegPath & vSubKey, "UserFolder", sUserFolder
If sServiceEndPointUri <> "" And sUserFolder <> "" Then
If Right(sServiceEndPointUri, 5) = "/_api" Then sServiceEndPointUri = Left(sServiceEndPointUri, Len(sServiceEndPointUri) - 4) & "Documents/"
sUserFolder = sUserFolder & "\"
coll_Locations.Add Item:=sServiceEndPointUri, Key:=sUserFolder
coll_Locations.Add Item:=sUserFolder, Key:=sServiceEndPointUri
End If
Next
'listOneDrv_Locations
Set oWMI = Nothing
End Sub
Public Sub listOneDrv_Locations()
' to list what's in the collection
Dim vKey As Variant
' Set coll_Locations = Nothing
If coll_Locations Is Nothing Then get_Locations
For Each vKey In coll_Locations
Debug.Print vKey, coll_Locations(vKey)
Next
End Sub
Then to get the LocalPath would be strLocalPath = getOneDrv_PathFor(strCurrentPath, "Local")
I know the question was tagged with VBA, but I found this while I was trying to solve with C#. I wrote a version similar to @TWMIC answer as the following:
string LocalPath( string fullPath )
{
if ( fullPath.StartsWith( "https://", StringComparison.InvariantCultureIgnoreCase ) )
{
// So Documents/ location works below
fullPath = fullPath.Replace( "\\", "/" );
var userAccounts = Microsoft.Win32.Registry.CurrentUser
.OpenSubKey(@"Software\Microsoft\OneDrive\Accounts\");
if (userAccounts != null)
{
foreach (var accountName in userAccounts.GetSubKeyNames())
{
var account = userAccounts.OpenSubKey(accountName);
var endPoint = account.GetValue("ServiceEndPointUri") as string;
var userFolder = account.GetValue("UserFolder") as string;
if (!string.IsNullOrEmpty(endPoint) && !string.IsNullOrEmpty(userFolder))
{
if (endPoint.EndsWith("/_api"))
{
endPoint = endPoint.Substring(0, endPoint.Length - 4) + "documents/";
}
if (fullPath.StartsWith(endPoint, StringComparison.InvariantCultureIgnoreCase))
{
return Path.Combine(userFolder, fullPath.Substring(endPoint.Length));
}
}
}
}
}
return fullPath;
}
I have recently found a new unique solution to this problem and because it is currently not described anywhere online I'd like to point it out here.
Microsoft recently added a new button to the Excel UI for OneDrive synchronized workbooks.
Clicking it copies the local path to the clipboard. This is the first official Microsoft solution for this problem I know of.
Unfortunately, this functionality is not (yet?) part of the object model, hence, to get this info in VBA, the button must be clicked by the code. This is possible but isn't 100% reliable. An example of how to do this looks like this:
Public Function GetLocalPathOfWorkbook(Optional ByVal wb As Workbook = Nothing) _
As String
If wb Is Nothing Then Set wb = ThisWorkbook
GetLocalPathOfWorkbook = wb.FullName
If Not wb.FullName Like "http*" Or wb.FullName = "" Then Exit Function
With Application
Dim appScreenUpdating As Boolean: appScreenUpdating = .ScreenUpdating
Dim appEnableEvents As Boolean: appEnableEvents = .EnableEvents
Dim appDisplayAlerts As Boolean: appDisplayAlerts = .DisplayAlerts
.ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False
End With
With wb.Windows(1)
Dim wbVisible As Boolean: wbVisible = .Visible
Dim wbWindowState As XlWindowState: wbWindowState = .WindowState
If Not .Visible Then .Visible = True
If .WindowState = xlMinimized Then .WindowState = xlNormal
.Activate
End With
On Error GoTo RestoreAppState
SendKeys "%f", True 'Weirdly, both, the SendKeys and the CommandBars.Execute
SendKeys "%i", True 'are necessary for the code to run reliably, even though
'they (should) just do the same thing twice in theory?
Application.CommandBars.ExecuteMso "FileProperties"
SendKeys "%l", True
SendKeys "{ESC}", True
DoEvents
GetLocalPathOfWorkbook = _
CreateObject("HtmlFile").parentWindow.clipboardData.GetData("text")
RestoreAppState:
wb.Windows(1).WindowState = wbWindowState
wb.Windows(1).Visible = wbVisible
Application.ScreenUpdating = appScreenUpdating
Application.EnableEvents = appEnableEvents
Application.DisplayAlerts = appDisplayAlerts
If Err.Number <> 0 Then Err.Raise Err
End Function
Unfortunately, this code sometimes randomly stops at the DoEvents line with the message "Code execution was interrupted.". This is very annoying, especially because clicking Debug and then Continue will let the code finish without further issues.
Since this solution uses SendKeys and UI automation it can also cause other random unforeseen problems or fail if the user interacts with the app while the code is running. Sometimes, issues even occur without external user interaction.
Apart from these drawbacks, this method is actually pretty powerful and can even be used to get the local path of any OneDrive/SharePoint "web path". (A "web path" is a link that's not a "share link")
This is possible because the Workbook.SaveAs method supports OneDrive URLs. Therefore, to find the local path, we can use code to create a temporary workbook in a location, open it, use the above-defined function, close it, and delete it again.
In the following, I've implemented a proof of concept to show that this works for arbitrary paths (Only if they exist!):
Public Function GetLocalPath(ByVal path As String)
GetLocalPath = path
If Not path Like "http*" Or path = "" Then Exit Function
Dim testWbName As String: testWbName = RandomStringAlphanumeric(6)
Dim wb As Workbook: Set wb = Application.Workbooks.Add
'Find out if path is a file or folder
Dim isFile As Boolean
If Not Right(path, 1) = "/" Then
On Error Resume Next
wb.SaveAs path & "/" & testWbName
If Err.Number = 1004 Then
On Error GoTo 0
wb.Saved = True 'The file that failed saving must be closed because
wb.Close SaveChanges:=xlDoNotSaveChanges 'next save attempt fails
Set wb = Nothing
isFile = True
End If
End If
If wb Is Nothing Then Set wb = Application.Workbooks.Add
'Save the test file if not already saved
On Error GoTo SaveFailed
If isFile Then
wb.SaveAs Left(path, InStrRev(path, "/")) & testWbName
ElseIf Right(path, 1) = "/" Then
wb.SaveAs path & testWbName
End If
On Error GoTo 0
'Get local path, close and delete file
Dim localTempFileFullName As String, localTempFilePath As String
localTempFileFullName = GetLocalPathOfWorkbook(wb)
localTempFilePath = Left(localTempFileFullName, InStrRev(localTempFileFullName, "\"))
wb.Saved = True
wb.Close SaveChanges:=xlDoNotSaveChanges
On Error GoTo DeleteFailed
CreateObject("Scripting.FileSystemObject").DeleteFile localTempFileFullName
On Error GoTo 0
If isFile Then
GetLocalPath = localTempFilePath & Mid(path, InStrRev(path, "/") + 1)
Else
If Right(path, 1) = "/" Then
GetLocalPath = localTempFilePath
Else
GetLocalPath = Left(localTempFilePath, Len(localTempFilePath) - 1)
End If
End If
Exit Function
SaveFailed:
If Err.Number = 1004 Then
On Error GoTo 0
wb.Saved = True
wb.Close SaveChanges:=xlDoNotSaveChanges
Exit Function
End If
Err.Raise Err
Exit Function
DeleteFailed:
MsgBox "GetLocalPath failed to get the local path of '" & path & "'" & _
vbNewLine & "A temporary file named " & testWbName & ".xlsx was " & _
"created in the location '" & path & "', please delete it manually." _
, vbCritical
Err.Raise Err.Number, "GetLocalPath", _
"Failed to delete this file: " & path & testWbName
End Function
Private Function RandomStringAlphanumeric(ByVal Length As Long) As String
Dim b() As Byte, i As Long, char As Long: Randomize
If Length < 1 Then Exit Function
ReDim b(0 To Length * 2 - 1)
For i = 0 To Length - 1
Select Case Rnd
Case Is < 0.41935: Do: char = 25 * Rnd + 65: Loop Until char <> 0
Case Is < 0.83871: Do: char = 25 * Rnd + 97: Loop Until char <> 0
Case Else: Do: char = 9 * Rnd + 48: Loop Until char <> 0
End Select
b(2 * i) = (Int(char)) And 255
Next i
RandomStringAlphanumeric = b
End Function
Even though this method seems alluring as it is using an 'official' way of obtaining the local path without hacking around in the registry/settings files, it is, as of now, much less reliable than the universal solution, which is currently marked as the accepted answer in this thread.
The main problems are, that it is very slow and error-prone, due to a large amount of UI automation involved in my attempted solution. Also, it doesn't work on Mac, as the backstage view is not available there.
Currently, I would much prefer the universal (currently accepted) solution in every possible scenario, its advantages are numerous:
GetLocalPathOfWorkbook works like that too, GetLocalPath does not.Workbook.SaveAs as used in this post must save the file directly to OneDrive.Workbook.SaveAs fails, for example for paths with many more obscure Unicode characters that make the URL-encoded path exceedingly long. The universal solution from the accepted answer can deal with that.To give an approximate idea of the capabilities of this method, in the testing presented here it gets between 30 and 40 of 46 tests right and takes around 500 seconds. Importantly though, it can not complete a test run without user interaction because of the many randomly occurring errors. Also, there are some tests, that currently always fail.
In light of all the drawbacks of this method, even this short solution is, by far, preferable.
If a more reliable way of clicking that button is found, without using SendKeys and physically navigating to the file info section, it could potentially be very useful in the future, especially on already open workbooks.
If anyone has some ideas on how to potentially do that, please let me know!
I guess there is a little bug in the code of JK2017: The"ShortName"-variable has to be rebuilt at every start of these 3 versions of OneDrive. So ist has to be inside the 'For i = 1 To 3' loop. I have also added the choise to get only the path instead of the full filename.
Private Function Local_Workbook_Name(ByRef wb As Workbook, Optional bPathOnly As Boolean = False) As String
'returns local wb path or nothing if local path not found
Dim i As Long, x As Long
Dim OneDrivePath As String
Dim ShortName As String
Dim testWbkPath As String
Dim OneDrivePathFound As Boolean
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'loop through three OneDrive options
For i = 1 To 3
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For x = 1 To 4
ShortName = RemoveTopFolderFromPath(ShortName)
Next
'Choose the version of Onedrive
OneDrivePath = Environ(Choose(i, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
Do While ShortName Like "*\*"
testWbkPath = OneDrivePath & "\" & ShortName
If Not (Dir(testWbkPath)) = vbNullString Then
OneDrivePathFound = True
Exit Do
End If
'remove top folder in path
ShortName = RemoveTopFolderFromPath(ShortName)
Loop
End If
If OneDrivePathFound Then Exit For
Next i
Else
If bPathOnly Then
Local_Workbook_Name = RemoveFileNameFromPath(wb.FullName)
Else
Local_Workbook_Name = wb.FullName
End If
End If
If OneDrivePathFound Then
If bPathOnly Then
Local_Workbook_Name = RemoveFileNameFromPath(testWbkPath)
Else
Local_Workbook_Name = testWbkPath
End If
End If
End Function
Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid(ShortName, InStr(ShortName, "\") + 1)
End Function
Function RemoveFileNameFromPath(ByVal ShortName As String) As String
RemoveFileNameFromPath = Mid(ShortName, 1, Len(ShortName) - InStr(StrReverse(ShortName), "\"))
End Function
The different number of slashes "/" could be related with different versions of OneDrive (private/professional). Compare MatChrupczalski post on the msdn website: https://social.msdn.microsoft.com/Forums/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive?forum=officegeneral
Therefore I adapted the function to the following:
Sub TestMySolution()
MsgBox ActiveWorkbook.FullName & vbCrLf & LocalFullName(ActiveWorkbook.FullName)
End Sub
' 29.03.2020 Horoman
' main parts by Philip Swannell 14.01.2019
' combined with parts from MatChrupczalski 19.05.2019
' using environment variables of OneDrive
Private Function LocalFullName(ByVal fullPath As String) As String
Dim i As Long, j As Long
Dim oneDrivePath As String
Dim endFilePath As String
Dim iDocumentsPosition As Integer
'Check if it looks like a OneDrive location
If InStr(1, fullPath, "https://", vbTextCompare) > 0 Then
'for commercial OneDrive file path seems to be like "https://companyName-my.sharepoint.com/personal/userName_domain_com/Documents" & file.FullName)
If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then
'find "/Documents" in string and replace everything before the end with OneDrive local path
iDocumentsPosition = InStr(1, fullPath, "/Documents") + Len("/Documents") 'find "/Documents" position in file URL
endFilePath = Mid(fullPath, iDocumentsPosition) 'get the ending file path without pointer in OneDrive
Else
'for personal onedrive it looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName, _
' by replacing "https.." with OneDrive local path obtained from registry we can get local file path
'Remove the first four backslashes
endFilePath = Mid(fullPath, 9) ' removes "https://" and with it two backslashes
For i = 1 To 2
endFilePath = Mid(endFilePath, InStr(endFilePath, "/") + 1)
Next
End If
'Replace forward slashes with back slashes (URL type to Windows type)
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
For j = 1 To 3
oneDrivePath = Environ(Choose(j, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(oneDrivePath) > 0 Then
LocalFullName = oneDrivePath & Application.PathSeparator & endFilePath
If Dir(LocalFullName) <> "" Then
Exit Function 'that is it - WE GOT IT
End If
End If
Next j
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
LocalFullName = ""
End If
LocalFullName = fullPath
End Function
Have fun.
"OneDriveCommercial"/"OneDrive" for sharepoint style links and "OneDriveConsumer"/"OneDrive" for other links –
Adumbral Hallo this is how I do it, I found my the path through "SOFTWARE\SyncEngines\Providers\OneDrive":
private static string GetLocalPath(string url)
{
try
{
var oneDriveKey = Registry.CurrentUser.OpenSubKey(@"Software\SyncEngines\Providers\OneDrive");
if (oneDriveKey != null)
{
foreach (var subKeyName in oneDriveKey.GetSubKeyNames())
{
var subKey = oneDriveKey.OpenSubKey(subKeyName);
if (subKey != null)
{
var urlNameSpace = subKey.GetValue("UrlNamespace").ToString().Trim('/');
if (url.Contains(urlNameSpace) && subKey.GetValue("MountPoint") is string localLibraryPath)
{
string restOfDocumentPath = url.Substring(urlNameSpace.Length);
restOfDocumentPath = restOfDocumentPath.Replace('/', '\\');
return localLibraryPath + restOfDocumentPath;
}
}
}
}
}
catch (Exception e)
{
Console.WriteLine(e.Message);
}
return string.Empty;
}
Here's a small improvement on Philip Swannell's improvement of Virtuoso's original answer for when the number of "\" to remove from the path is more than 4 / varies (depending on the file, i found i needed to remove 5 or sometimes 6 of these). The shortcomings mentioned by Philip are still there though.
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
'returns local wb path or nothing if local path not found
Dim i As Long
Dim OneDrivePath As String
Dim ShortName As String
Dim testWbkPath As String
Dim OneDrivePathFound As Boolean
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For i = 1 To 4
ShortName = RemoveTopFolderFromPath(ShortName)
Next
'loop through three OneDrive options
For i = 1 To 3
OneDrivePath = Environ(Choose(i, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
Do While ShortName Like "*\*"
testWbkPath = OneDrivePath & "\" & ShortName
If Not (Dir(testWbkPath)) = vbNullString Then
OneDrivePathFound = True
Exit Do
End If
'remove top folder in path
ShortName = RemoveTopFolderFromPath(ShortName)
Loop
End If
If OneDrivePathFound Then Exit For
Next i
Else
Local_Workbook_Name = wb.FullName
End If
If OneDrivePathFound Then Local_Workbook_Name = testWbkPath
End Function
Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid(ShortName, InStr(ShortName, "\") + 1)
End Function
Call me a hacker but the http reference on my machine is always the same so I looked at the local reference on my hard drive where the OneDrive could be found
Lets say that was C:\MyOneDrive\OneDrive then took all the other parts of the workbook path that weren't needed and added on the local part. Then switched the slash direction
folder = "C:\MyOneDrive\OneDrive" & Right(Application.ActiveWorkbook.Path, Len(Application.ActiveWorkbook.Path) - 72) & "\"
folder = Replace(folder, "/", "\")
My two lines covered all the cases on my machine!!
I solved this problem be creating a symbolic link (mklink /d). Opening files through a desktop shortcut to the link meant that WB.FullName always returned the file path using the symbolic link.
As you all seem to work on Windows-System you can also use the filescripting object:
Debug.Print
Debug.Print "ThisWorkbook.Path: "; ThisWorkbook.Path
Debug.Print "ThisWorkbook.FullName: "; ThisWorkbook.FullName
With CreateObject("Scripting.FileSystemObject")
Debug.Print "Scripting.fso: "; .GetAbsolutePathName(ThisWorkbook.Name)
End With
I solved this without VBA. Instead I used Power Query.
First I use this formula in a cell, to get the path without filename and worksheetname:
=LEFT(CELL("filename";E8);FIND("[";CELL("filename";E8))-1)
Then I import the path as a table in Power Query: "Råfilsti"
I then have another query that has this as its source. Here I do some datawrangling on the HTTPS file path. I hard coded my local OneDrive path in the query, but you can copy paste your OneDrive root folder into a cell in Excel and call that as a parameter to use in Power Query.
Then load that query into a table in the workbook.
© 2022 - 2024 — McMap. All rights reserved.