thisworkbook.fullname与OneDrive同步后返回URL.我想要磁盘上的文件路径

Question

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

c:UsersMyNameOneDrive - MyCompanyBlaBlaMyWorkbook 09-21-17.xlsb

但是在VBA进行了一组操作之后

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纠正和重新设计的代码。它可以在我的机器上工作，但是我不确定它在其他设置上的功能如何。如果其他人可以测试，那就太好了。我会在解决方案上标记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}!\.rootdefault:StdRegProv")
    Dim strRegPath As String: strRegPath = "SoftwareSyncEnginesProvidersOneDrive"
    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

edit：

此答案现在已经过时了，这篇文章的结论是不完整的。请改用此解决方案！

---

我现在已经浏览了网络上此问题的大量解决方案，包括各种堆叠线线程，它们都不适用于所有不同类型的OneDrive文件夹/帐户。

这是我对该线程中解决方案测试的简短摘要：

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

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

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

@henrikBø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}!\." & _
                           "rootdefault:StdRegProv")
    rPath = "SoftwareSyncEnginesProvidersOneDrive"
    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

Answer 4

这是解决此问题的解决方案。SharePoint库将其分配到本地MountPoints存储在注册表中，以下功能将将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}!\.rootdefault:StdRegProv")
    Dim strRegPath As String: strRegPath = "SoftwareSyncEnginesProvidersOneDrive"
    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 5

我使用Windows一个环境变量来解决此问题。

在我的示例中，我使用了一个私人的OneDrive，但是更改代码以处理OneDrive的业务非常简单。然后，环境变量将是" OneDrivepcrized"而不是" 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 6

如果您有个人OneDrive，请使用环境

代码：环境（'OneDriveCmercial; quot; quot; replace（right（thisworkbook.fullname，len（thisworkbook.fullname）） - （instral（thisworkbook.fullname，;＆quotsy'＆quotsys/documents/documents'＆quote n documents'＆quotions 9）），;＆quort;;）

"/documents/＆quot"应该是标准的，但是您的OneDrive可能具有不同的设置。如果是这样，您需要替换＆quot＆quot/documents/＆quot;（OneDrive前缀的末尾）与您所拥有的一切。并替换" 9"要成为您所拥有的负2。

Answer 7

https://answers.microsoft.com/en-us/msoffice/msoffice/forum/all/在线路径返回 - 远程 - 比本地路径/2EA9970D-383B-4893-AFAB-38041FEE65FE

这对我有用。没有额外的代码

打开OneDrive应用程序设置＆gt;转到办公室标签＆GT;untick'使用办公应用程序来同步我打开的"我打开的办公室文件"，然后重新打开您的工作簿

Answer 8

如果您只是想做saveas，实际上有一个称为"本地"的参数" ，它将导致所有属性（fullname/path/etc。）根据本地计算机的语言解决。

只需添加＆quot'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://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas

Answer 9

感谢Beerockxs和RMK的出色回答。

我不得不进行一些次要的调整才能使其可靠地工作。例如，在我的情况下，返回了CID值，但CID实际上并不是完整的OneDrive URL的一部分。因此，因此，剥夺了我的角色数量，打破了我的本地路径。

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

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

我还添加了一些简单的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}!\.rootdefault:StdRegProv")
    Dim strRegPath As String: strRegPath = "SoftwareSyncEnginesProvidersOneDrive"
    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