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？

Answer 1

这是来自 beerockxs 的更正和重新设计的代码。它可以在我的机器上运行，但我不确定它在其他设置上的运行情况如何。如果其他人可以测试，那就太好了。我将在解决方案中标记 beerockx 的答案。

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

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)

Answer 3

编辑：

\n

这个答案现在已经过时了，这篇文章的结论也不完整。请看看这个解决方案！

\n\n

我现在已经在网上浏览了一系列针对此问题的解决方案，包括各种 StackOverflow 线程，但没有一个适用于所有不同类型的 OneDrive 文件夹/帐户。

\n

以下是我对此线程中解决方案的测试的简短摘要：

\n

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

\n

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

\n

@Danny\'s 解决方案仅在非常罕见的情况下有效，对我来说它从来没有工作过

\n

@Henrik B\xc3\xb8gelund\ 的解决方案不起作用

\n

@Erik van der Neut\ 的解决方案在大多数情况下都有效，但在私有 OneDrive 的情况下，它会"\\"在路径中引入一个额外的内容。这很容易修复，但如果同步文件夹不在在线文件结构中的文件夹层次结构的基础上，它也不起作用。在这种情况下，WebPath 中存在额外的路径部分，这些部分会被带入本地路径，从而使其无效。

\n

以下功能在大多数情况下都有效，对于通用解决方案，请查看此答案。

\n

Public Function GetLocalPath(ByVal Path As String) As String\n    Const HKCU = &H80000001\n    Dim objReg As Object, rPath As String, subKeys(), subKey\n    Dim urlNamespace As String, mountPoint As String, secPart As String\n    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\." & _\n                           "\\root\\default:StdRegProv")\n    rPath = "Software\\SyncEngines\\Providers\\OneDrive\\"\n    objReg.EnumKey HKCU, rPath, subKeys\n    For Each subKey In subKeys\n        objReg.GetStringValue HKCU, rPath & subKey, "UrlNamespace", urlNamespace\n        If InStr(Path, urlNamespace) > 0 Then\n            objReg.GetStringValue HKCU, rPath & subKey, "MountPoint", mountPoint\n            secPart = Replace(Mid(Path, Len(urlNamespace)), "/", "\\")\n            Path = mountPoint & secPart\n            Do Until Dir(Path, vbDirectory) <> "" Or InStr(2, secPart, "\\") = 0\n                secPart = Mid(secPart, InStr(2, secPart, "\\"))\n                Path = mountPoint & secPart\n            Loop\n            Exit For\n        End If\n    Next\n    GetLocalPath = Path\nEnd Function\n

\n

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