Excel的Onename驱动器的全名属性

Question

如果我想在保存后使用打开的Workbook对象获取Excel文件的全名,但该文件已同步到OneDrive,我会得到一个"https"地址而不是本地地址,其他程序无法解释.
如何获取这样的文件的本地文件名？

示例:
将文件保存到"C:\ Users\user\OneDrive - Company\Documents".
OneDrive进行同步.
查询Workbook.FullName现在显示为"https:// ..."

Answer 1

通用解决方案和所有解决方案的荟萃分析

\n

总而言之：

\n

\n

• 如需解决方案，请跳至解决方案部分

  \n
\n

• 对于荟萃分析，请跳至解决方案的测试和比较部分

  \n
\n

\n

背景

\n

@Cristian Buse 和我在测试了所有其他在线可用的解决方案并发现它们都不是普遍准确的之后，对这个问题进行了广泛的研究。

\n

最终我们双方都制定了独立的解决方案：

\n

\n

• @Cristian Buse 开发了他的解决方案，作为他优秀的 VBA 库之一的一部分，具体来说，是 Library VBA-FileTools。该库还提供了许多其他非常有用的功能。

  \n
\n

• 我自己的解决方案采用独立函数的形式，没有任何依赖项。如果此问题发生在不需要附加功能的小型项目中，这非常有用。由于实现所需的通用功能很复杂，因此单个过程非常漫长且复杂。

  \n
\n

\n\n

解决方案

\n

笔记：

\n

\n
• 如果您在我们的解决方案中遇到任何错误，请在此处或在 GitHub 上报告！在这种情况下，我建议您同时使用此解决方案，因为它是可用的下一个最准确的解决方案。
\n

\n

解决方案 1 - 库

\n

将此库：VBA-FileTools\n从 GitHub 导入到您的项目中。获取工作簿的本地名称非常简单：

\n

GetLocalPath(ThisWorkbook.FullName)\n

\n

\n

^{注意:
\n于 2023 年 4 月 5 日向此解决方案添加了完整的 Mac 支持。
\n于 2023 年 9 月 25 日向此解决方案添加了对 OneDrive 版本 23.184.0903.0001 的支持。}

\n

\n

解决方案 2 - 独立功能

\n

将此函数从 GitHub Gist 复制到任何标准代码模块中。

\n

现在获取工作簿的本地名称的工作方式与解决方案 1 相同：

\n

GetLocalPath(ThisWorkbook.FullName)\n

\n

\n

^{注意：
\n此解决方案于 2022 年 12 月 20 日添加了部分 Mac 支持，并于 2023 年 3 月 20 日添加了全面支持。
\n此解决方案于 2023 年 10 月 2 日添加了对 OneDrive 版本 23.184.0903.0001 的支持。
\n此功能还提供一些可选参数，但几乎永远不需要它们。（有关更多信息，请参阅要点）}

\n

\n

您还可以直接从此处复制该函数：^{由于 StackOverflows 30 000 字符答案长度限制而缩短。}

\n

\'Function for converting a OneDrive URL to the corresponding local path\n\'Algorithmically shortened code from here: \n\'https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d\n\'Author: Guido Witt-D\xc3\xb6rring\nPublic Function GetLocalPath$(ByVal path$, Optional ByVal returnAll As Boolean = False, Optional ByVal preferredMountPointOwner$ = "", Optional ByVal rebuildCache As Boolean = False)\n#If Mac Then\nConst dp& = 70\nConst ch$ = ".849C9593-D756-4E56-8D6E-42412F2A707B"\nConst er As Boolean = True\nConst ab$ = "/"\n#Else\nConst ab$ = "\\"\nConst er As Boolean = False\n#End If\nConst be$ = "GetLocalPath"\nConst es& = 53\nConst fl& = 7\nConst fm& = 457\nConst fn& = 325\nStatic ac As collection, et As Date\nIf Not Left(path, 8) = "https://" Then GetLocalPath = path: Exit Function\nDim r$, h$, b$, e\nDim dq$: dq = LCase$(preferredMountPointOwner)\nIf Not ac Is Nothing And Not rebuildCache Then\nDim bn As collection: Set bn = New collection\nFor Each e In ac\nh = e(0): r = e(1)\nIf InStr(1, path, r, vbTextCompare) = 1 Then bn.Add Key:=e(2), Item:=Replace(Replace(path, r, h, , 1), "/", ab)\nNext e\nIf bn.count > 0 Then\nIf returnAll Then\nFor Each e In bn: b = b & "//" & e: Next e\nGetLocalPath = Mid$(b, 3): Exit Function\nEnd If\nOn Error Resume Next: GetLocalPath = bn(dq): On Error GoTo 0\nIf GetLocalPath <> "" Then Exit Function\nGetLocalPath = bn(1): Exit Function\nEnd If\nGetLocalPath = path\nEnd If\nDim bg As collection: Set bg = New collection\nDim ax, ds$\n#If Mac Then\nDim ci$, dt As Boolean\nb = Environ("HOME")\nds = b & "/Library/Application Support/Microsoft/Office/CLP/"\nb = Left$(b, InStrRev(b, "/Library/Containers/", , vbBinaryCompare))\nbg.Add b & "Library/Containers/com.microsoft.OneDrive-mac/Data/Library/Application Support/OneDrive/settings/"\nbg.Add b & "Library/Application Support/OneDrive/settings/"\nci = b & "Library/CloudStorage/"\n#Else\nbg.Add Environ("LOCALAPPDATA") & "\\Microsoft\\OneDrive\\settings\\"\nds = Environ("LOCALAPPDATA") & "\\Microsoft\\Office\\CLP\\"\n#End If\nDim a&\n#If Mac Then\nDim ay(): ReDim ay(1 To bg.count * 11 + 1)\nFor Each ax In bg\nFor a = a + 1 To a + 9\nay(a) = ax & "Business" & a Mod 11\nNext a\nay(a) = ax: a = a + 1\nay(a) = ax & "Personal"\nNext ax\nay(a + 1) = ci\nDim du As Boolean\ndu = getsetting("GetLocalPath", "AccessRequestInfoMsg", "Displayed", "False") = "True"\nIf 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\nIf Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be\n#End If\nDim cz As collection: Set cz = New collection\nFor Each ax In bg\nDim g$: g = Dir(ax, vbDirectory)\nDo Until g = vbNullString\nIf g = "Personal" Or g Like "Business#" Then cz.Add Item:=ax & g & ab\ng = Dir(, vbDirectory)\nLoop\nNext ax\nIf Not ac Is Nothing Or er Then\nDim bf As collection: Set bf = New collection\nDim f\nFor Each f In cz\nDim t$: t = iif(f Like "*" & ab & "Personal" & ab, "????????????*", "????????-????-????-????-????????????")\nDim p$: p = Dir(f, vbNormal)\nDo Until p = vbNullString\nIf 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\np = Dir\nLoop\nNext f\nEnd If\nIf Not ac Is Nothing And Not rebuildCache Then\nDim at\nFor Each at In bf\nIf FileDateTime(at) > et Then rebuildCache = True: Exit For\nNext at\nIf Not rebuildCache Then Exit Function\nEnd If\nDim c&, am$, d() As Byte, i&, q&\nDim bp&, au() As Byte, ck$\nDim l() As Byte, ao$, aj() As Byte\nDim az() As Byte, bq$, av&\nDim y&, dx&, dy&\net = Now()\n#If Mac Then\nDim z As collection: Set z = New collection\ng = Dir(ci, vbDirectory)\nDo Until g = vbNullString\nIf g Like "OneDrive*" Then\ndt = True\nf = ci & g & ab\nat = ci & g & ab & ch\nz.Add Item:=f\nbf.Add Item:=f\nbf.Add Item:=at\nEnd If\ng = Dir(, vbDirectory)\nLoop\nIf ac Is Nothing Then\nDim da\nIf bf.count > 0 Then\nReDim da(1 To bf.count)\nFor a = 1 To UBound(da): da(a) = bf(a): Next a\nIf Not GrantAccessToMultipleFiles(da) Then Err.Raise dp, be\nEnd If\nEnd If\nIf dt Then\nFor a = z.count To 1 Step -1\nDim br&: br = 0\nOn Error Resume Next\nbr = GetAttr(z(a) & ch)\nDim bs As Boolean: bs = False\nIf Err.Number = 0 Then bs = Not CBool(br And vbDirectory)\nOn Error GoTo 0\nIf Not bs Then\ng = Dir(z(a), vbDirectory)\nDo Until g = vbNullString\nIf Not g Like ".Trash*" And g <> "Icon" Then\nz.Add z(a) & g & ab\nz.Add z(a) & g & ab & ch, z(a) & g & ab\nEnd If\ng = Dir(, vbDirectory)\nLoop\nz.Remove a\nEnd If\nNext a\nIf z.count > 0 Then\nReDim ay(1 To z.count)\nFor a = 1 To z.count: ay(a) = z(a): Next a\nIf Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be\nEnd If\nOn Error Resume Next\nFor a = z.count To 1 Step -1\nz.Remove z(a)\nNext a\nOn Error GoTo 0\nDim dz As collection\nSet dz = New collection\nFor Each f In z\nbr = 0\nOn Error Resume Next\nbr = GetAttr(f & ch)\nbs = False\nIf Err.Number = 0 Then bs = Not CBool(br And vbDirectory)\nOn Error GoTo 0\nIf bs Then\nc = FreeFile(): b = "": at = f & ch\nDim ea As Boolean: ea = False\nOn Error GoTo ReadFailed\nOpen at For Binary Access Read As #c\nReDim d(0 To LOF(c)): Get c, , d: b = d\nea = True\nReadFailed: On Error GoTo -1\nClose #c: c = 0\nOn Error GoTo 0\nIf ea Then\nau = b\nIf LenB(b) > 0 Then\nReDim l(0 To LenB(b) * 2 - 1): q = 0\nFor i = LBound(au) To UBound(au)\nl(q) = au(i): q = q + 2\nNext i\nb = l\nElse: b = vbNullString\nEnd If\nElse\nat = MacScript("return path to startup disk as string") & Replace(Mid$(at, 2), ab, ":")\nb = MacScript("return read file """ & at & """ as string")\nEnd If\nIf InStr(1, b, """guid"" : """, vbBinaryCompare) Then\nb = Split(b, """guid"" : """)(1)\nam = Left$(b, InStr(1, b, """", 0) - 1)\ndz.Add Key:=am, Item:=VBA.Array(am, Left$(f, Len(f) - 1))\nElse\nDebug.Print "Warning, empty syncIDFile encountered!"\nEnd If\nEnd If\nNext f\nEnd If\nIf Not du Then savesetting "GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"\n#End If\nDim j, w$(), s&, cl$\nDim db$, dc$, cm$, bj$\nDim aa$, ak$, aq$\nDim bx$, ew$, by As Boolean\nDim bz$, ca$, dd$, ex$\nDim ey$, af$, ez$\nDim fa$: fa = chrb$(2)\nDim eb As String * 4: MidB$(eb, 1) = chrb$(1)\nDim ec$: ec = chrb$(0)\n#If Mac Then\nConst ed$ = vbNullChar & vbNullChar\n#Else\nConst ed$ = vbNullChar\n#End If\nDim cn As collection, fd As Date\nSet cn = New collection\nSet ac = New collection\nFor Each f In cz\ng = Mid$(f, InStrRev(f, ab, Len(f) - 1, 0) + 1)\ng = Left$(g, Len(g) - 1)\nIf Dir(f & "global.ini", vbNormal) = "" Then GoTo NextFolder\nc = FreeFile()\nOpen f & "global.ini" For Binary Access Read As #c\nReDim d(0 To LOF(c)): Get c, , d\nClose #c: c = 0\n#If Mac Then\nbq = d: GoSub DecodeUTF8\nd = ao\n#End If\nFor Each j In Split(d, vbNewLine)\nIf j Like "cid = *" Then t = Mid$(j, 7): Exit For\nNext j\nIf t = vbNullString Then GoTo NextFolder\nIf (Dir(f & t & ".ini") = vbNullString Or (Dir(f & "SyncEngineDatabase.db") = vbNullString And Dir(f & t & ".dat") = vbNullString)) Then GoTo NextFolder\nIf g Like "Business#" Then\nbx = Replace(Space$(32), " ", "[a-f0-9]") & "*"\nElseIf g = "Personal" Then\nbx = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"\nEnd If\np = Dir(ds, vbNormal)\nDo Until p = vbNullString\na = InStrRev(p, t, , vbTextCompare)\nIf a > 1 And t <> vbNullString Then bj = LCase$(Left$(p, a - 2)): Exit Do\np = Dir\nLoop\n#If Mac Then\nOn Error Resume Next\nfd = cn(g)\nby = (Err.Number = 0)\nOn Error GoTo 0\nIf by Then\nIf FileDateTime(f & t & ".ini") < fd Then\nGoTo NextFolder\nElse\nFor a = ac.count To 1 Step -1\nIf ac(a)(5) = g Then\nac.Remove a\nEnd If\nNext a\ncn.Remove g\ncn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")\nEnd If\nElse\ncn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")\nEnd If\n#End If\nDim ba As collection: Set ba = New collection\np = Dir(f, vbNormal)\nDo Until p = vbNullString\nIf p Like "ClientPolicy*.ini" Then\nc = FreeFile()\nOpen f & p For Binary Access Read As #c\nReDim d(0 To LOF(c)): Get c, , d\nClose #c: c = 0\n#If Mac Then\nbq = d: GoSub DecodeUTF8\nd = ao\n#End If\nba.Add Key:=p, Item:=New collection\nFor Each j In Split(d, vbNewLine)\nIf InStr(1, j, " = ", vbBinaryCompare) Then\ndb = Left$(j, InStr(1, j, " = ", 0) - 1)\nb = Mid$(j, InStr(1, j, " = ", 0) + 3)\nSelect Case db\nCase "DavUrlNamespace"\nba(p).Add Key:=db, Item:=b\nCase "SiteID", "IrmLibraryId", "WebID"\nb = Replace(LCase$(b), "-", "")\nIf Len(b) > 3 Then b = Mid$(b, 2, Len(b) - 2)\nba(p).Add Key:=db, Item:=b\nEnd Select\nEnd If\nNext j\nEnd If\np = Dir\nLoop\nDim x As collection: Set x = Nothing\nIf Dir(f & t & ".dat") = vbNullString Then GoTo Continue\nConst fs& = 1000\nConst cp& = 255\nDim bb&: bb = -1\nTry: On Error GoTo Catch\nSet x = New collection\nDim cq&: cq = 1\nDim cr As Date: cr = FileDateTime(f & t & ".dat")\na = 0\nDo\nIf FileDateTime(f & t & ".dat") > cr Then GoTo Try\nc = FreeFile\nOpen f & t & ".dat" For Binary Access Read As #c\nDim df&: df = LOF(c)\nIf bb = -1 Then bb = df\nReDim d(0 To bb + fs)\nGet c, cq, d: b = d\nDim cs&: cs = LenB(b)\nClose #c: c = 0\ncq = cq + bb\nFor e = 16 To 8 Step -8\na = InStrB(e + 1, b, eb, 0)\nDo While a > e And a < cs - 168\nIf StrComp(MidB$(b, a - e, 1), fa, 0) = 0 Then\na = a + 8: s = InStrB(a, b, ec, 0) - a\nIf s < 0 Then s = 0\nIf s > 39 Then s = 39\n#If Mac Then\nck = MidB$(b, a, s)\nGoSub DecodeANSI: ak = ao\n#Else\nak = StrConv(MidB$(b, a, s), vbUnicode)\n#End If\na = a + 39: s = InStrB(a, b, ec, 0) - a\nIf s < 0 Then s = 0\nIf s > 39 Then s = 39\n#If Mac Then\nck = MidB$(b, a, s)\nGoSub DecodeANSI: aa = ao\n#Else\naa = StrConv(MidB$(b, a, s), vbUnicode)\n#End If\na = a + 121\ns = InStr(-Int(-(a - 1) / 2) + 1, b, ed, 0) * 2 - a - 1\nIf s > cp * 2 Then s = cp * 2\nIf s < 0 Then s = 0\nIf ak Like bx And aa Like bx Then\n#If Mac Then\nDo While s Mod 4 > 0\nIf s > cp * 4 Then Exit Do\ns = InStr(-Int(-(a + s) / 2) + 1, b, ed, 0) * 2 - a - 1\nLoop\nIf s > cp * 4 Then s = cp * 4\naj = MidB$(b, a, s)\nReDim l(LBound(aj) To UBound(aj))\ni = LBound(aj): q = LBound(aj)\nDo While i < UBound(aj)\nIf aj(i + 2) + aj(i + 3) = 0 Then\nl(q) = aj(i)\nl(q + 1) = aj(i + 1)\nq = q + 2\nElse\nIf aj(i + 3) <> 0 Then Err.Raise fn, be\ny = aj(i + 2) * &H10000 + aj(i + 1) * &H100& + aj(i)\nbp = y - &H10000\ndy = &HD800& Or (bp \\ &H400&)\ndx = &HDC00& Or (bp And &H3FF)\nl(q) = dy And &HFF&\nl(q + 1) = dy \\ &H100&\nl(q + 2) = dx And &HFF&\nl(q + 3) = dx \\ &H100&\nq = q + 4\nEnd If\ni = i + 4\nLoop\nIf q > LBound(l) Then\nReDim Preserve l(LBound(l) To q - 1)\naq = l\nElse: aq = vbNullString\nEnd If\n#Else\naq = MidB$(b, a, s)\n#End If\nx.Add VBA.Array(aa, aq), ak\nEnd If\nEnd If\na = InStrB(a + 1, b, eb, 0)\nLoop\nIf x.count > 0 Then Exit For\nNext e\nLoop Until cq >= df Or bb >= df\nGoTo Continue\nCatch:\nSelect Case Err.Number\nCase fm\nx.Remove ak\nResume\nCase Is <> fl: Err.Raise Err, be\nEnd Select\nIf bb > &HFFFFF Then bb = bb / 2: Resume Try\nErr.Raise Err, be\nContinue:\nOn Error GoTo 0\nIf Not x Is Nothing Then GoTo SkipDbFile\nc = FreeFile()\nOpen f & "SyncEngineDatabase.db" For Binary Access Read As #c\ncs = LOF(c)\nIf cs = 0 Then GoTo CloseFile\nDim ee$: ee = chrw$(&H808)\nConst fx& = 8\nConst fy& = -3\nConst fg As Byte = 9\nConst fh& = 6\nConst fz& = &H16\nConst ga& = &H15\nConst cc& = -16\nConst dj& = -15\nConst ef& = &H100000\nDim bk&, cd&, bc&\nDim ag(1 To 4) As Byte\nDim an$, dk$\nDim eg&\nDim eh&\nDim ei&, dl&\nDim ej As Byte, ek As Byte\nDim el As Boolean\ncr = 0\nReDim d(1 To ef)\nDo\na = 0\nIf FileDateTime(f & "SyncEngineDatabase.db") > cr Then\nSet x = New collection\nDim dm As collection: Set dm = New collection\ncr = FileDateTime(f & "SyncEngineDatabase.db")\nbk = 1\nan = vbNullString\nEnd If\nIf LenB(an) > 0 Then\naq = MidB$(b, eg, eh)\nEnd If\nGet c, bk, d\nb = d\na = InStrB(1 - cc, b, ee, vbBinaryCompare)\ndl = 0\nDo While a > 0\nIf a + cc - 2 > dl And LenB(an) > 0 Then\nIf dl > 0 Then\naq = MidB$(b, eg, eh)\nEnd If\nbq = aq: GoSub DecodeUTF8\naq = ao\nOn Error Resume Next\nx.Add VBA.Array(dk, aq), an\nIf Err.Number <> 0 Then\nIf dm(an) < ek Then\nIf x(an)(1) <> aq Or x(an)(0) <> dk Then\nx.Remove an\ndm.Remove an\nx.Add VBA.Array(dk, aq), an\nEnd If\nEnd If\nEnd If\ndm.Add ek, an\nOn Error GoTo 0\nan = vbNullString\nEnd If\nIf d(a + fy) <> fx Then GoTo NextSig\nel = True\nIf d(a + dj) = ga Then\ni = a + dj\nElseIf d(a + cc) = fz Then\ni = a + cc\nel = False\nElseIf d(a + dj) <= fg Then\ni = a + dj\nElse\nGoTo NextSig\nEnd If\nej = d(i)\ncd = fh\nFor q = 1 To 4\nIf q = 1 And ej <= fg Then\nag(q) = d(i + 2)\nElse\nag(q) = d(i + q)\nEnd If\nIf ag(q) < 37 Or ag(q) Mod 2 = 0 Then GoTo NextSig\nag(q) = (ag(q) - 13) / 2\ncd = cd + ag(q)\nNext q\nIf el Then\nbc = d(i + 5)\nIf bc < 15 Or bc Mod 2 = 0 Then GoTo NextSig\nbc = (bc - 13) / 2\nElse\nbc = (d(i + 5) - 128) * 64 + (d(i + 6) - 13) / 2\nIf bc < 1 Or d(i + 6) Mod 2 = 0 Then GoTo NextSig\nEnd If\ncd = cd + bc\nei = a + cd - 1\nIf ei > ef Then\na = a - 1\nExit Do\nEnd If\ni = a + fh\n#If Mac Then\nck = MidB$(b, i, ag(1))\nGoSub DecodeANSI: ak = ao\n#Else\nak = StrConv(MidB$(b, i, ag(1)), vbUnicode)\n#End If\ni = i + ag(1)\naa = StrConv(MidB$(b, i, ag(2)), vbUnicode)\n#If Mac Then\nck = MidB$(b, i, ag(2))\nGoSub DecodeANSI: aa = ao\n#Else\naa = StrConv(MidB$(b, i, ag(2)), vbUnicode)\n#End If\nIf ak Like bx And aa Like bx Then\neg = i + ag(2) + ag(3) + ag(4)\neh = bc\nan = Left(ak, 32)\ndk = Left(aa, 32)\nek = ej\ndl = ei\nEnd If\nNextSig:\na = InStrB(a + 1, b, ee, vbBinaryCompare)\nLoop\nIf a = 0 Then\nbk = bk + ef + cc\nElse\nbk = bk + a + cc\nEnd If\nLoop Until bk > cs\nCloseFile:\nClose #c\nSkipDbFile:\nc = FreeFile()\nOpen f & t & ".ini" For Binary Access Read As #c\nReDim d(0 To LOF(c)): Get c, , d\nClose #c: c = 0\n#If Mac Then\nbq = d: GoSub DecodeUTF8:\nd = ao\n#End If\nSelect Case True\nCase g Like "Business#"\nDim em As collection: Set em = New collection\ndc = vbNullString\nFor Each j In Split(d, vbNewLine)\nr = "": h = "": w = Split(j, """")\nSelect Case Left$(j, InStr(1, j, " = ", 0) - 1)\nCase "libraryScope"\nh = w(9)\naf = h: am = Split(w(10), " ")(2)\ncl = Split(j, " ")(2)\new = w(3): w = Split(w(8), " ")\nbz = w(1): dd = w(2): ca = w(3)\nIf dc = vbNullString Or ew = "ODB" Then\ndc = h: p = "ClientPolicy.ini"\ney = am: ez = af\nElse: p = "ClientPolicy_" & ca & bz & ".ini"\nEnd If\nOn Error Resume Next\nr = ba(p)("DavUrlNamespace")\nOn Error GoTo 0\nIf r = "" Then\nFor Each e In ba\nIf e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then\nr = e("DavUrlNamespace"): Exit For\nEnd If\nNext e\nEnd If\nIf r = vbNullString Then Err.Raise es, be\nem.Add VBA.Array(cl, r), cl\nIf Not h = vbNullString Then ac.Add VBA.Array(h, r, bj, am, af, g), Key:=h\nCase "libraryFolder"\ncl = Split(j, " ")(3)\nh = w(1): af = h\nam = Split(w(4), " ")(1)\nb = vbNullString: aa = Left$(Split(j, " ")(4), 32)\nDo\nOn Error Resume Next: x aa\nby = (Err.Number = 0): On Error GoTo 0\nIf Not by Then Exit Do\nb = x(aa)(1) & "/" & b\naa = x(aa)(0)\nLoop\nr = em(cl)(1) & b\nac.Add VBA.Array(h, r, bj, am, af, g), h\nCase "AddedScope"\ncm = w(5): If cm = " " Then cm = ""\nw = Split(w(4), " "): bz = w(1)\ndd = w(2): ca = w(3): ex = w(4)\np = "ClientPolicy_" & ca & bz & ex & ".ini"\nOn Error Resume Next\nr = ba(p)("DavUrlNamespace") & cm\nOn Error GoTo 0\nIf r = "" Then\nFor Each e In ba\nIf e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then\nr = e("DavUrlNamespace") & cm\nExit For\nEnd If\nNext e\nEnd If\nIf r = vbNullString Then Err.Raise es, be\nb = vbNullString: aa = Left$(Split(j, " ")(3), 32)\nDo\nOn Error Resume Next: x aa\nby = (Err.Number = 0): On Error GoTo 0\nIf Not by Then Exit Do\nb = x(aa)(1) & ab & b\naa = x(aa)(0)\nLoop\nh = dc & ab & b\nac.Add VBA.Array(h, r, bj, ey, ez, g), h\nCase Else: Exit For\nEnd Select\nNext j\nCase g = "Personal"\nFor Each j In Split(d, vbNewLine)\nIf j Like "library = *" Then\nw = Split(j, """"): h = w(3)\naf = h: am = Split(w(4), " ")(2)\nExit For\nEnd If\nNext j\nOn Error Resume Next\nr = ba("ClientPolicy.ini")("DavUrlNamespace")\nOn Error GoTo 0\nIf h = "" Or r = "" Or t = "" Then GoTo NextFolder\nac.Add VBA.Array(h, r & "/" & t, bj, am, af, g), Key:=h\nIf Dir(f & "GroupFolders.ini") = "" Then GoTo NextFolder\nt = vbNullString: c = FreeFile()\nOpen f & "GroupFolders.ini" For Binary Access Read As #c\nReDim d(0 To LOF(c)): Get c, , d\nClose #c: c = 0\n#If Mac Then\nbq = d: GoSub DecodeUTF8\nd = ao\n#End If\nFor Each j In Split(d, vbNewLine)\nIf j Like "*_BaseUri = *" And t = vbNullString Then\nt = LCase$(Mid$(j, InStrRev(j, "/", , 0) + 1, InStrRev(j, "!", , 0) - InStrRev(j, "/", , 0) - 1))\nak = Left$(j, InStr(1, j, "_", 0) - 1)\nElseIf t <> vbNullString Then\nac.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)\nt = vbNullString: ak = vbNullString\nEnd If\nNext j\nEnd Select\nNextFolder:\nt = vbNullString: b

        
      
    

Answer 2

简短的解决方案

下面介绍的解决方案并不适用于所有情况，但它可能适用于 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)

Answer 3

我在网上发现了一个包含足够信息的线程,可以将一些简单的东西放在一起来解决 我实际上是在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

Answer 4

Horoman 的版本 (2020-03-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 /sf/ask/2361429451/
    '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

Answer 5

我已经调整了其他人提供的功能以考虑一些额外的额外限制：

• 当您通过团队网站共享文件时，您应该使用“my.sharepoint.com/”而不是“sharepoint.com/”来确定它是否是商业版本。

• 最好计算斜杠而不是使用“/Documents”的位置，因为例如在法语中，文档文件夹称为“Documents partages”。最好计算 4 个用于商业用途的斜线和 2 个用于个人用途的斜线。

• 如果作为 OneDrive 快捷方式添加的 SharePoint 文件夹不在根目录下，则硬盘驱动器上的本地地址不包含 SharePoint 上的父文件夹。

这是将我的更改考虑在内的代码：

Public Function AdresseLocal$(ByVal fullPath$)
    'Finds local path for a OneDrive file URL, using environment variables of OneDrive
    'Reference /sf/ask/2361429451/
    '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

...建立在不同贡献者的工作之上。

Answer 6

Easy Fix（2019 年初）- 对于遇到此问题的其他人：

OneDrive > 设置 > Office：- 取消选中“使用 Office 应用程序同步我打开的 Office 文件”

这使得 Excel 以典型的“C:\Users[用户名]\OneDrive...”文件格式而不是 UNC“https:\”格式保存文件。

Answer 7

我喜欢 TWMIC 的使用注册表的版本。所有其他版本都无法在我的 oneDrive for Business 上运行。有些文件夹的名称与 URL 略有不同，例如 URL 中部分没有空格，但文件夹中有空格。如果它来自团队并且团队名称中有空格，那么这是一个问题。即使 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 /sf/ask/2361429451/
'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

对我来说这非常有用！

Answer 8

可以改善Virtuoso的答案，以减少（但不能消除）该函数返回“错误”文件位置的机会。问题在于工作簿.FullName可以有各种URL 。我知道这三个：

1. 与用户的OneDrive关联的URL
2. 与用户的OneDrive for Business关联的URL
3. 如果其他人“共享”了文件，则与其他人的OneDrive关联的URL（在这种情况下，您可以通过“文件”>“打开”>“与我共享”来打开文件）

在我的PC上，我可以通过OneDriveConsumer和OneDriveCommercial环境变量来获取相关的本地文件夹来映射前两个URL，该环境变量除了OneDrive环境变量外还存在，因此下面的代码使用了这些文件夹。我不知道可以处理“与我共享”文件，并且下面的代码将返回其https://-style位置。

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文件夹中都存在具有相同路径的文件，则代码无法区分它们，并可能返回“错误的一个”。我没有解决方案。