这个问题的标题是：如何获取已同步到OneDrive的文件在磁盘上的路径？ ThisWorkbook.FullName在与OneDrive同步后返回一个URL，我需要获取磁盘上的文件路径。

Question

我在OneDrive上有一个工作簿。通常，ThisWorkbook.FullName返回磁盘上的路径：

c:\Users\MyName\OneDrive - MyCompany\BlaBla\MyWorkbook 09-21-17.xlsb

但在使用VBA进行一系列操作之后，我手动将文件保存到备份文件夹并将当前文件重命名为新日期，OneDrive同步后，ThisWorkbook.FullName返回一个URL:

https://mycompany.sharepoint.com/personal/MyName_Company_com/Documents/mycompany/Apps/BlaBla/MyWorkbook 10-21-17.xlsb

我需要获取磁盘路径，即使ThisWorkbook.FullName返回的是一个URL。

如果我想草率地解决问题，我可以在我的操作之前保存路径，但我希望能够随时检索磁盘路径。

我看到其他人编写的一些过程，像这个，但它更多地只是将URL格式化为磁盘上的路径。这样做并不可靠，因为URL路径和磁盘路径的目录结构不总是相同的（请参见链接过程中所做的重新格式化与我上面给出的示例目录结构之间的比较）。

是否有一种稳定、直接的方法返回工作簿的磁盘路径，即使它正在进行在线同步并且ThisWorkbook.FullName返回的是一个URL？

- RMK

---

我相信你提供的“hack”是唯一的方法。ThisWorkbook.FullName返回它所返回的内容。 - Mathieu Guindon

在同步之前和之后，CurDir返回什么？ - Mathieu Guindon

"C:\Users\MyName\Documents"编辑：同步前后均如此。 - RMK

一个逻辑上的下一步是从该字符串中删除“文档”，并添加OneDrive文件夹，但是，这个OneDrive文件夹名称可能因为不同的人分享方式而有所不同。 - RMK

@RMK，你可能想要查看这个解决方案。我也在你的帖子中回答了，但是我会将我的主要答案放在另一个帖子中，因为它更早，有更多的浏览量/赞数/答案，简而言之，曝光率更高。 - GWD

Answer 1

这是从beerockxs进行修正和改进后的代码。它在我的电脑上可以运行，但我不确定它在其他设置上的表现如何。如果其他人能够测试，那就太好了。我将把beerockxs的答案标记为解决方案。

Function GetLocalFile(wb As Workbook) As String
    ' Set default return
    GetLocalFile = wb.FullName
    
    Const HKEY_CURRENT_USER = &H80000001

    Dim strValue As String
    
    Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    Dim strRegPath As String: strRegPath = "Software\SyncEngines\Providers\OneDrive\"
    Dim arrSubKeys() As Variant
    objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys
    
    Dim varKey As Variant
    For Each varKey In arrSubKeys
        ' check if this key has a value named "UrlNamespace", and save the value to strValue
        objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strValue
    
        ' If the namespace is in FullName, then we know we have a URL and need to get the path on disk
        If InStr(wb.FullName, strValue) > 0 Then
            Dim strTemp As String
            Dim strCID As String
            Dim strMountpoint As String
            
            ' Get the mount point for OneDrive
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint
            
            ' Get the CID
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID
            
            ' Add a slash, if the CID returned something
            If strCID <> vbNullString Then
                strCID = "/" & strCID
            End If

            ' strip off the namespace and CID
            strTemp = Right(wb.FullName, Len(wb.FullName) - Len(strValue & strCID))
            
            ' replace all forward slashes with backslashes
            GetLocalFile = strMountpoint & Replace(strTemp, "/", "\")
            Exit Function
        End If
    Next
End Function

- RMK

---

非常好的解决方案RMK，谢谢你，它真的帮了我大忙。我不得不做一个改变——在我的系统上字符串strCID是空的，这导致*Len(strValue&"/"&strCID)*多了一个字符(以两个斜杠结束)。因此，变量strTemp对于我来说返回"ocuments/.."而不是"Documents/.."。我在对strTemp的定义中添加了if-else语句来解决这个问题。 - Floris

谢谢你，Floris！我已经更新了我的代码以解决这个问题。 - RMK

请给这个答案更多的信任，它是唯一一个可靠解决问题的方案。其他帖子中类似的答案完全忽略了从注册表中获取URL + 本地路径对，并仅提供了本地路径。 - Ryszard Jędraszyk

不错的解决方案。我建议在第三行后添加以下代码： If Instr(GetLocalFile,"https://") = 0 Then Exit function 如果文件实际上不在OneDrive上，这将加快处理速度。 - Philip Swannell

感谢RMK - 这真的是非常有帮助。我只需要进行了一些微小的调整，可以看看我刚刚发布的回答。 - Erik van der Neut

Answer 2

Sub get_folder_path()

'early binding
Dim fso As FileSystemObject
Set fso = New FileSystemObject

'late binding
'Dim fso As Object
'Set fso = CreateObject("Scripting.FileSystemObject")

Dim folder As String
folder = fso.GetAbsolutePathName(ThisWorkbook.Name)
Debug.Print (folder)

- Danny

---

对我来说非常好用。这是我迄今为止见过的最优雅的解决方案。 - wjamyers

起初我认为这个方法可行，但实际上它似乎无法给出正确的磁盘路径。说实话，它看起来只是在你输入的任何内容前面添加了“c:\Users\MyName\Documents”。 - RMK

良好地使用FSO对象。现在我所需要做的就是修剪/删除文件名，以获取仅文件夹路径。 - Eddie Kumar

我确认 @RMK 的评论。它返回 "c:\Users\MyName\Documents\MyFile.xlsm"，而正确的完整路径是 "c:\Users\MyName\Documents\auto\MyFile.xlsm"。 - 6diegodiego9

fso.GetAbsolutePathName(ThisWorkbook.Name) 只会返回 CurDir & "" & ThisWorkbook.Name。实际上，如果您在此之前执行了 ChDir 操作，它将使用新的更改后的 CurDir。 - 6diegodiego9

Answer 3

编辑：

此答案已过时，本文结论不完整，请查看这个解决方案！

---

我现在已经查看了一堆网络上的解决方案，包括各种StackOverflow线程，但它们都不能适用于所有不同类型的OneDrive文件夹/帐户。

以下是我对本主题中各种解决方案的测试的简要总结：

@RMK 的解决方案仅适用于 个人 OneDrive 文件夹

@beerockxs 的解决方案也仅适用于 个人 OneDrive 文件夹

@Danny 的解决方案仅在非常罕见的情况下起作用，而对我来说从未起作用过

@Henrik Bøgelund 的解决方案没有起作用

@Erik van der Neut 的解决方案在大多数情况下都有效，但在私有 OneDrive 的情况下，它会将一个额外的"\"引入到路径中。虽然这很容易修复，但如果在线文件结构中的同步文件夹不处于文件层次结构的基础位置，则无法工作。在这种情况下，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

- GWD

---

对我来说工作正常，将"https://d.docs.live.net/e06a[etc...]/Documenti/MyFolder/MyFile.xlsm"正确转换为"C:\Users\myUserName\OneDrive\Documenti\MyFolder\MyFile.xlsm"。谢谢！ - 6diegodiego9

Answer 4

这里有一个解决此问题的方法。Sharepoint库分配到本地挂载点是存储在注册表中的，以下函数将把URL转换为本地文件名。我进行了编辑，以整合RMK的建议：

Function GetLocalFile(wb As Workbook) As String
    ' Set default return
    GetLocalFile = wb.FullName

    Const HKEY_CURRENT_USER = &H80000001

    Dim strValue As String

    Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    Dim strRegPath As String: strRegPath = "Software\SyncEngines\Providers\OneDrive\"
    Dim arrSubKeys() As Variant
    objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys

    Dim varKey As Variant
    For Each varKey In arrSubKeys
        ' check if this key has a value named "UrlNamespace", and save the value to strValue
        objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strValue

        ' If the namespace is in FullName, then we know we have a URL and need to get the path on disk
        If InStr(wb.FullName, strValue) > 0 Then
            Dim strTemp As String
            Dim strCID As String
            Dim strMountpoint As String
        
            ' Get the mount point for OneDrive
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint
        
            ' Get the CID
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID
        
            ' strip off the namespace and CID
            strTemp = Right(wb.FullName, Len(wb.FullName) - Len(strValue & "/" & strCID))
        
            ' replace all forward slashes with backslashes
            GetLocalFile = strMountpoint & Replace(strTemp, "/", "\")
            Exit Function
        End If
    Next
End Function

- beerockxs

---

我觉得我们离成功不远了。当我在家里的电脑上测试这个程序并将Excel文件放在根目录的OneDrive目录中时，我得到了类似于以下的输出： "C:\Users\UserName\OneDrive\1a1234a123456abc\filename.xlsb"正确的输出应该是： "C:\Users\UserName\OneDrive\filename.xlsb""1a1234a123456abc" 是CID，而且似乎多了一个斜杠。 - RMK

我已经让它工作了。如果你修复一些东西，我会将你的答案标记为解决方案。你必须从注册表中提取CID并从路径中删除它。你还要连接一个不必要的反斜杠。查看我编写的完整代码的答案。 - RMK

啊，当你的文件在OneDrive的根目录中时，反斜杠是不必要的，我的测试用例都在OneDrive的根目录的子文件夹中。 - beerockxs

Floris 遇到了一个 CID 返回空字符串的情况。我的代码会在空字符串后添加一个斜杠，导致多出一个斜杠。为了解决这个问题，我在下面更新了我的代码，并添加了几行用于测试空字符串。 - RMK

Answer 5

如果您有个人的OneDrive，请使用Environ("OneDriveConsumer")。

代码： Environ("OneDriveCommercial")+Replace(Right(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - (InStr(ThisWorkbook.FullName, "/Documents/") + 9)),"/","")

"/Documents/" 应该是标准的，但您的OneDrive可能有不同的设置。如果是这样，您需要将"/Documents/"（OneDrive前缀的结尾）替换为您所拥有的内容，并将"9"替换为您所拥有的长度减去2。

- Mike Lewis

---

这是一个完美的解决方案。你在行末错过了一个\吗？Environ("OneDriveCommercial")+Replace(Right(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - (InStr(ThisWorkbook.FullName, "/Documents/") + 9)),"/","") - Roy Keane

Answer 6

我使用了Windows环境变量来解决这个问题。

在我的例子中，我使用的是私人版OneDrive，但是改变代码以处理OneDrive for Business是相当简单的。环境变量将变为“OneDriveCommercial”，而不是“OneDriveConsumer”。

以下是将OneDrive URL转换为本地路径的代码：

Rem consumer URL to OneDrive root: "https://d.docs.live.net/<64-bit hex value>/"
OneDriveServerURL = "https://d.docs.live.net/"

path = ActiveWorkbook.path
Worksheets("Menu").Range("G6").Value = path

If Left(path, Len(OneDriveServerURL)) = OneDriveServerURL Then
  Rem remove from start to first "/" after server URL
  path = Mid(path, InStr(Len(OneDriveServerURL) + 1, path, "/"))

  Rem replce "/" by "\"
  path = Replace(path, "/", Application.PathSeparator)

  Rem add OneDrive root folder from environment variable
  path = Environ("OneDriveConsumer") + path
End If

- Henrik Bøgelund

---

在即时窗口中，Environ("OneDriveConsumer")或Environ("OneDriveCommercial")都没有返回任何内容。 - RMK

尝试以下操作：

1. 打开命令提示符（按下Windows键并输入cmd）。
2. 输入命令：“set”。
3. 按回车键。 现在应该列出所有环境变量。 在我的Windows机器上，我有上述两个变量 - 但也许您的实现不同，并使用第三个名称来表示变量。

- Henrik Bøgelund

Answer 7

感谢beerockxs和RMK的出色回答。

我不得不进行一些小的调整，以使其可靠地工作。例如，在我的情况下，返回了一个CID值，但CID实际上并不是完整的OneDrive URL的一部分。因此，由于这个原因，通过计算字符数来剥离CID会破坏我的本地路径。

作为解决方案，我不是通过计算字符数来剥离CID和URL名称空间，而是通过简单的字符串替换操作来实现。这样，如果您收到一个CID值，它不是URL的一部分，它就不会从URL中删除任何内容。这也使代码更易于阅读。

在我的情况下，我需要我的Excel电子表格的本地根文件夹，因此还创建了一个简单的额外方法。

我还添加了一些简单的Mac检查（避免尝试在Mac上运行，因为它不适用于Mac），并添加了一些调试MsgBox调用--一旦您发现它对您也起作用，请将其注释掉：

Function GetLocalPath(wb As Workbook) As String

    strLocalFile = GetLocalFile(wb)
    
    ' Remove everything after the last slash to get just the path itself:
    GetLocalPath = Left(strLocalFile, InStrRev(strLocalFile, "\"))
    
    ''''''''''''''' DEBUG '''''''''''''''''''''''''
    MsgBox "Local file:" & vbCrLf & strLocalFile & vbCrLf & vbCrLf & "Local path:" & vbCrLf & GetLocalPath
    ''''''''''''''' DEBUG '''''''''''''''''''''''''

End Function


Function GetLocalFile(wb As Workbook) As String
#If Mac Then
    MsgBox "Sorry, this script only works on Windows."
#Else
    ' Set default return
    GetLocalFile = wb.FullName
    
    Const HKEY_CURRENT_USER = &H80000001

    Dim strUrlNameSpace As String
    
    Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    Dim strRegPath As String: strRegPath = "Software\SyncEngines\Providers\OneDrive\"
    Dim arrSubKeys() As Variant
    objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys
    
    Dim varKey As Variant
    For Each varKey In arrSubKeys
        ' Check if this key has a value named "UrlNamespace", and save the value to strUrlNameSpace:
        objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strUrlNameSpace
        
        ' If the namespace is in FullName, then we know we have a URL and need to get the path on disk:
        If InStr(wb.FullName, strUrlNameSpace) > 0 Then
            Dim strTemp As String
            Dim strCID As String
            Dim strMountpoint As String
            
            ' Get the mount point for OneDrive, and make sure it ends in "\":
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint
            If Right(strMountpoint, 1) <> "\" Then
                strMountpoint = strMountpoint & "\"
            End If
            
            ' Get the CID, and add "/" at the start if any value returned:
            objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID
            If strCID <> vbNullString Then
                strCID = "/" & strCID
            End If

            ' Replace the URL name space with local mount point:
            strTemp = Replace(wb.FullName, strUrlNameSpace, strMountpoint)
            
            ' Remove CID from the path if the CID is indeed part of it:
            strTemp = Replace(strTemp, strCID, "")
            
            ' Replace any remaining forward slashes with backslashes:
            GetLocalFile = Replace(strTemp, "/", "\")
            
            ''''''''''''''' DEBUG '''''''''''''''''''''''''
            MsgBox "OneDrive URL:" & vbCrLf & wb.FullName & vbCrLf & vbCrLf & "URL Name Space (strUrlNameSpace):" & vbCrLf & strUrlNameSpace & vbCrLf & vbCrLf & "OneDrive Mount Point (strMountpoint):" & vbCrLf & strMountpoint & vbCrLf & vbCrLf & "CID (strCID):" & vbCrLf & strCID & vbCrLf & vbCrLf & "Local file:" & vbCrLf & GetLocalFile
            ''''''''''''''' DEBUG '''''''''''''''''''''''''
            
            Exit Function
        End If
    Next
#End If
End Function

在测试中验证了这个现在完美地工作，无论是在OneDrive文件夹还是普通文件夹中。

Erik

- Erik van der Neut

Answer 8

https://answers.microsoft.com/en-us/msoffice/forum/all/online-path-returned-rather-than-local-path/2ea9970d-383b-4893-afab-38041fee65fe

这对我很有帮助。没有额外的代码。

打开OneDrive应用程序设置 > 转到Office选项卡 > 取消选中“使用Office应用程序同步我打开的Office文件”，然后重新打开您的工作簿。

- Devin

Answer 9

如果你只是想要进行SaveAs操作，实际上有一个名为“Local”的参数，它会使所有属性（FullName/Path等）基于本地机器的语言解析。

只需在SaveAs调用中添加“Local:=True”，你就可以顺利完成操作了。

所以在我的情况下，我使用：

Sub ExportCurrentWorkbook()
 Dim ws As Worksheet
 Set ws = Application.ActiveSheet
 
 Application.ScreenUpdating = False
 ws.Copy

 ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ws.Name & ".csv", xlCSVUTF8, _
 ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges, Local:=True

 ActiveWorkbook.Close SaveChanges = True
 Application.ScreenUpdating = True
   
End Sub

MSDN 参考： https://learn.microsoft.com/zh-cn/office/vba/api/excel.workbook.saveas

- BlackHatCS