简介:
要查看解决方案，请跳至解决方案部分
要进行元分析，请跳至解决方案的测试和比较部分
在测试了所有在线可用的解决方案后，@Cristian Buse和我对这个问题进行了广泛的研究，发现没有一个解决方案是普遍准确的。
最终，我们分别开发了独立的解决方案：
@Cristian Buse开发了他的解决方案，作为他出色的VBA库之一的一部分，具体来说，是库VBA-FileTools。该库还提供了许多其他非常有用的功能。
我的解决方案以独立的函数形式存在，没有任何依赖关系。这在小型项目中出现此问题时非常有用，不需要额外的功能。由于实现所需的通用功能很复杂，对于单个过程来说非常冗长和复杂。
注意：
将此库导入到您的项目中：VBA-FileTools。然后，获取您工作簿的本地名称就变得非常简单：
GetLocalPath(ThisWorkbook.FullName)
注意：
此解决方案于2023年4月5日添加了对Mac的全面支持。
此解决方案于2023年9月25日添加了对OneDrive版本23.184.0903.0001的支持。
从GitHub Gist复制this function到任何标准代码模块中。
现在，获取工作簿的本地名称的方式与解决方案1相同：
GetLocalPath(ThisWorkbook.FullName)
'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
这两种解决方案从目录%localappdata%\Microsoft\OneDrive\settings\...中的OneDrive设置文件中获取将OneDrive URL转换为本地路径所需的所有信息。
可以读取以下文件：
(通配符：* - 零个或多个字符；? - 一个字符)
????????????????.dat
????????????????.ini
global.ini
GroupFolders.ini
????????-????-????-????-????????????.dat
????????-????-????-????-????????????.ini
ClientPolicy*.ini
SyncEngineDatabase.db
C:\Users\Username\OneDrive，相应的URL根目录可能是这样的：https://d.docs.live.net/f9d8c1184686d493。我对所有我能在网上找到的解决方案进行了广泛的测试。这里将呈现一部分测试结果。
以下是一些经过测试的解决方案的列表：
我在网上找到了一个帖子，里面包含足够的信息来组合解决方案。我实际上是用 Ruby 实现了这个解决方案，但这是 VBA 版本：
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谢谢！ - BBKHoroman's version（2020年3月30日）很好，因为它适用于私人和商业OneDrive。但是它在我的电脑上崩溃了，因为“LocalFullName = oneDrivePath & Application.PathSeparator & endFilePath”这一行在oneDrivePath和endFilePath之间插入了一个斜杠。此外，在使用“OneDrive”路径之前，确实应该尝试使用“OneDriveCommercial”和“OneDriveConsumer”路径。所以这是对我有用的代码：
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://dev59.com/W1sX5IYBdhLWcg3wf_r3
'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% 或同等情况，endFilePath 行应为 endFilePath = IIf(iPos = 0, "", Mid(wbPath, iPos))。 - Malan KrielEnviron("OneDriveCommercial")和Environ("OneDriveConsumer")，如果两个都失败了，再回退到Environ("OneDrive")呢？这样做感觉商业版文件可能会覆盖消费者版文件，即使原始链接是"https://d.docs.live.net..."这种风格的链接也一样？ - Greedo以下提供的解决方案并不在所有情况下都适用，但它可能在99%以上的实际场景中有效。如果您正在寻找一种涵盖边缘情况的解决方案，请查看这个通用解决方案。
与上面链接的通用解决方案相比，这种解决方案的一个优点是它很简单，因此更不容易因为OneDrive/Windows更新而出现问题。
将"WebPath"转换为本地路径的函数如下：
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
现在，只需使用GetLocalPath(ThisWorkbook.FullName)即可获取您工作簿的本地完整名称。
我调整了其他人提供的函数，以考虑一些额外的限制：
当您通过团队网站共享文件时，应使用“sharepoint.com/”而不是“my.sharepoint.com/”来确定是否为商业版本。
最好计算斜杠的数量，而不是使用“/Documents”的位置，因为例如在法语中，文档文件夹称为“Documents partages”。 商业用途应计算4个斜杠，个人用途应计算2个斜杠。
如果将SharePoint文件夹添加为OneDrive的快捷方式，并且它不位于根目录，则硬盘驱动器上的本地地址不包含SharePoint上的父文件夹。
这是带有我的更改的代码：
Public Function AdresseLocal$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive
'Reference https://dev59.com/W1sX5IYBdhLWcg3wf_r3
'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
...这是在不同贡献者的工作基础上构建而成的。
ByVal fullPath$？只需要传递 ActiveWorkbook.Path 吗？ - MistakamikazeThisWorkbook.Path传入作为父目录，将ThisWorkbook.FullName传入作为文件本身。 - GreedoInStr(1, Mid$(path_, 9, InStr(9, path_, "/") - 9), "sharepoint", vbTextCompare) > 0搜索“sharepoint”关键字，以便仅检查根目录。 - Cristian Buse.FullName可能与多个URL相关联，以下是我知道的三种情况：
OneDriveConsumer和OneDriveCommercial环境变量获取相关的本地文件夹，除了OneDrive环境变量之外，因此下面的代码将利用这些变量。我不知道如何处理“与我共享”的文件，并且下面的代码将返回它们的https://样式位置。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
很遗憾，如果在OneDrive文件夹和OneDrive for Business文件夹中存在路径相同的文件，则代码无法区分它们，可能会返回“错误”的文件。我没有解决方案。
易修复（2019年初）- 如果其他人也遇到了这个问题：
OneDrive > 设置 > Office： - 取消选中“使用Office应用程序同步我打开的Office文件”
这使得Excel可以将文件保存在典型的“C:\Users[用户名]\OneDrive…”文件格式中，而不是UNC“https:\"格式。
我喜欢使用TWMIC版本并使用注册表进行操作。其他所有版本都无法在我的OneDrive for Business中运行。有一些文件夹名称与URL略有不同，例如URL中部分没有空格，但在文件夹中有空格。如果它是来自Teams并且团队名称中有空格，则会出现问题。即使是来自Teams的文件夹名称也与URL不同，这取决于您正在同步的Teams中的文件夹级别。
TWMIC版本被标记为危险，在我的工作电脑上无法使用，非常遗憾。 因此，我制作了一个版本，可以读取OneDrive for Business中的ini文件，如果是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://dev59.com/W1sX5IYBdhLWcg3wf_r3
'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
对我来说，这非常有效！
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 执行时，它返回的是 C:\Users\deepstop\OneDrive\deepstop_idc_com\Documents\Shared with Noone\etc\etc，其中既不包含 deepstop_idc_com 也不包含 Documents。 - DeepstopFullname=CurDir&FileName，而不是FullName=activeworkbook.Path&FileName。这样返回的是完整的本地名称，没有https等内容，我能够成功打开我的文件。
CELL仅适用于当前工作簿 - 只是说一下，除了翻译当前工作簿的路径之外，还有其他用途。 - Cristian Buse