ThisWorkbook.FullName returns URL 与 OneDrive 同步后。我想要磁盘上的文件路径

Question

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

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

但是在 VBA 中的一组操作之后，我手动将文件保存到备份文件夹并使用新日期重命名当前文件，OneDrive 同步并且 ThisWorkbook.FullName returns一个 URL:

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

我需要磁盘路径，即使 ThisWorkbook.FullName returns a URL.

如果我想一起破解一些东西，我可以在操作前保存路径，但我希望能够随时检索磁盘路径。

我见过一些其他人一起破解的程序，，但它或多或少只是将 URL 重新格式化为磁盘上的路径。这样做是不可靠的，因为 URL 路径和磁盘路径并不总是具有相同的目录结构（请参阅与我在上面示例中给出的目录结构相比，链接过程中完成的重新格式化）。

是否有可靠、直接的方法返回工作簿在磁盘上的路径，即使它在线同步并且 ThisWorkbook.FullName 返回 URL？

Answer 1

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 2

我使用了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

Answer 3

这是解决此问题的方法。 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

Answer 4

这是来自 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 5

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

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

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

Answer 6

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 文件”，然后重新打开您的工作簿

Answer 7

如果您只是尝试另存为，实际上有一个名为“本地”的参数，它将导致所有属性 (FullName/Path/etc.) 解析基于本地机器的语言。

只需将“Local:=True”添加到 SaveAs 调用，就可以了。

所以在我的例子中我使用：

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://docs.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

ThisWorkbook.FullName returns URL 与 OneDrive 同步后。我想要磁盘上的文件路径

ThisWorkbook.FullName returns a URL after syncing with OneDrive. I want the file path on disk

excel

sharepoint

vba

onedrive