返回Excel VBA宏OneDrive本地路径-可能的潜在客户

我有一个很多人都需要访问的电子表格（在sharepoint上），出于一些原因，我们需要在本地（同步）执行此操作

然而，由于每个用户的知识水平，不断出现问题和错误，电子表格需要具有结构和一致性，因此为了实现这一点，我创建了一个带有一组参数的用户表单，以帮助人们输入准确的数据并避免错误

它是一个投标登记簿，用于输入客户、客户联系人和投标信息，生成报价编号、文件夹和文件名等

OneDrive/Sharepoint路径更改之前（以前文件路径是本地的，现在是Sharepoint URL） 我有一个宏，当用户单击按钮时会运行，该宏将在相关的本地sharepoint目录中创建一个适当命名的文件夹，在该文件夹中创建一组标准文件夹（客户文档、合同、产品文件、图纸等），然后打开投标表格并将其保存在创建的文件夹中。文件名（报价编号）用于从投标登记簿中查找查询，以返回所有客户/联系人/报价信息

由于sharepoint已将其路径协议从本地更改为URL，因此我无法使其正常工作，从而导致手动过程，从而导致错误和不一致

我已到处搜索使用VBA在sharepoint上创建文件夹和文件的方法，以及与本地路径交互的方法，而不是禁用“使用Office应用程序同步我打开的Office文件”（由于文件协作，此功能是必需的） 当我找到一种将URL转换为本地路径的方法时，我有一个希望，但是，这不是最好的解决方案，因为每个用户都在不同级别同步文件夹（也许有人可以帮助我确定路径，一个宏在OneDrive目录中搜索文件夹“2021投标者”并返回路径……但我认为这可能会很慢）

然而，我注意到，如果我转到File>Info，有一个“Open File Location”按钮，它直接将我带到文件的本地路径文件夹，它告诉我这些信息在excel中的某个地方，必须有一种方法来检索它，我在任何搜索中都没有看到对它的引用，当我指出它时，有没有人对如何或是否可以这样做有任何想法？ 我试图录制一个宏，但它根本没有注册它

任何帮助都将不胜感激，并提前向您表示感谢

---

这是我根据另一个答案（参见代码中的注释）组装的东西

代码属于我组合的一系列类，但为了给您一个复杂而简单的答案，请在模块中加入以下内容：

Option Explicit
Private Const ONEDRIVE_TENANTS_REGISTRY_FOLDER As String = "Software\Microsoft\OneDrive\Accounts\Business1\Tenants\"
Private Const ONEDRIVE_TOTAL_VERSIONS As Long = 3
Private Const ONEDRIVE_PATH_SLASHES As Long = 4
Const HKEY_CURRENT_USER = &H80000001
Public Function GetLocalWorkbookName(ByVal fullName As String, Optional ByVal PathOnly As Boolean = False) As String
    ' Credits: https://stackoverflow.com/a/57040668/1521579
    'returns local wb path or empty string if local path not found

    Dim localFolders As Collection
    Dim localFolder As Variant
    
    Dim evalPath As String
    Dim result As String
    
    Dim isOneDrivePath As Boolean
    
    'Check if it looks like a OneDrive location
    isOneDrivePath = InStr(1, fullName, "https://", vbTextCompare) > 0
    
    If isOneDrivePath = False Then
        result = fullName
    Else
        Set localFolders = GetLocalFolders
        
        evalPath = RemoveTopFoldersByQty(fullName, ONEDRIVE_PATH_SLASHES)
        For Each localFolder In localFolders
            result = GetFilePathByRootFolder(localFolder, evalPath)
            If result <> vbNullString Then Exit For
        Next localFolder
    End If
    If PathOnly Then
        GetLocalWorkbookName = RemoveFileNameFromPath(result)
    Else
        GetLocalWorkbookName = result
    End If
    
End Function
Public Function GetLocalFolders() As Collection
    
    Dim tempCollection As Collection
    Dim tenantFolders As Variant
    Dim localFolders As Variant
    
    Dim tenantCounter As Long

    Set tempCollection = New Collection
    
    ' Look in onedrive for business tenant's folders
    tenantFolders = GetRegistrySubKeys(ONEDRIVE_TENANTS_REGISTRY_FOLDER)
    
    For tenantCounter = 0 To UBound(tenantFolders)
        localFolders = GetRegistryValues(ONEDRIVE_TENANTS_REGISTRY_FOLDER & "\" & tenantFolders(tenantCounter) & "\")
        AddArrayItemsToCollection tempCollection, localFolders
    Next tenantCounter
    
    ' Add the onedrive consumer folder
    tempCollection.Add Environ$("OneDriveConsumer")
    
    Set GetLocalFolders = tempCollection
    
End Function
Public Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
    RemoveTopFolderFromPath = Mid$(ShortName, InStr(ShortName, "\") + 1)
End Function

Public Function RemoveTopFoldersByQty(ByVal FullPath As String, ByVal FolderQty As Long) As String
    Dim counter As Long
    Dim evalPath As String
    evalPath = Replace(FullPath, "/", "\")
    For counter = 1 To FolderQty
        evalPath = RemoveTopFolderFromPath(evalPath)
    Next counter
    RemoveTopFoldersByQty = evalPath
End Function

Public Function RemoveFileNameFromPath(ByVal ShortName As String) As String
    RemoveFileNameFromPath = Mid$(ShortName, 1, Len(ShortName) - InStr(StrReverse(ShortName), "\"))
End Function

Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
    Dim result As String
    Dim evalPath As String
    Dim testFilePath As String
    
    Dim oneDrivePathFound As Boolean
       
    evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
    
    Do While evalPath Like "*\*"
        testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
        If Not (Dir(testFilePath)) = vbNullString Then
            oneDrivePathFound = True
            Exit Do
        End If
        'remove top folder in path
        evalPath = RemoveTopFolderFromPath(evalPath)
    Loop
    
    If oneDrivePathFound = True Then
        result = testFilePath
    Else
        result = vbNullString
    End If
    
    GetFilePathByRootFolder = result
    
End Function
Public Function GetRegistrySubKeys(ByVal pathToFolder As String) As Variant
' Credits: https://stackoverflow.com/a/8667984/1521579
    Dim registryObject As Object
    Dim computerID As String
    Dim subkeys() As Variant
    'Dim key As Variant

    computerID = "."
    Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    computerID & "\root\default:StdRegProv")

    registryObject.EnumKey HKEY_CURRENT_USER, pathToFolder, subkeys
    GetRegistrySubKeys = subkeys
    'For Each key In subKeys
    '    Debug.Print key
    'Next
End Function

Public Function GetRegistryValues(ByVal pathToFolder As String) As Variant
' Credits: https://stackoverflow.com/a/8667984/1521579
    Dim registryObject As Object
    Dim computerID As String
    Dim values() As Variant
    Dim valuesTypes() As Variant
    'Dim value As Variant
    

    computerID = "."
    Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    computerID & "\root\default:StdRegProv")

    registryObject.EnumValues HKEY_CURRENT_USER, pathToFolder, values, valuesTypes
    GetRegistryValues = values
    'For Each value In values
    '    Debug.Print value
    'Next
End Function



Public Sub AddArrayItemsToCollection(ByVal evalCollection As Collection, ByVal evalArray As Variant)
    
    Dim item As Variant
    
    For Each item In evalArray
        evalCollection.Add item
    Next item
    
End Sub

---

希望有帮助，让我知道它是否有效

该代码对于每个onedrive/sharepoint根同步文件夹（顶级）的子文件夹中的文件非常有效 但如果文件本身处于顶层，则不会

我仔细检查了代码，看看它在哪里通过每个斜杠过滤 在“GetFilePathByRootFolder”函数中，我将“do while”改为“for”。 使用“do while”循环计算斜杠的数量，然后对斜杠数量+1执行“for”循环，再运行一次“RemoveTopFolderFromPath”，只留下文件名供最后一次在根文件夹中搜索文件名

希望这是有意义的

    Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
    Dim result As String
    Dim evalPath As String
    Dim testFilePath As String
    Dim slashCounter As Integer                                                                         'added by AC
    Dim i As Integer                                                                                    'added by AC
    
    Dim oneDrivePathFound As Boolean
       
    evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
    
    slashCounter = 0                                                                                    'added by AC
    Do While evalPath Like "*\*"                                                                        'added by AC
        slashCounter = slashCounter + 1                                                                 'added by AC
        evalPath = RemoveTopFolderFromPath(evalPath)                                                    'added by AC
    Loop                                                                                                'added by AC
    slashCounter = slashCounter + 1
    evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath

    For i = 1 To slashCounter                                                                           'added by AC
        testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath        'added by AC
        Debug.Print testFilePath                                                                        'added by AC
        If Not (Dir(testFilePath)) = vbNullString Then                                                  'added by AC
            oneDrivePathFound = True                                                                    'added by AC
            Exit For                                                                                    'added by AC
        End If                                                                                          'added by AC
        'remove top folder in path                                                                      'added by AC
        evalPath = RemoveTopFolderFromPath(evalPath)                                                    'added by AC
    Next i                                                                                              'added by AC
    
'    Do While evalPath Like "*\*" ' change loop to "for each \ in evalPath +1"
'        testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
'        Debug.Print testFilePath
'        If Not (Dir(testFilePath)) = vbNullString Then
'            oneDrivePathFound = True
'            Exit Do 'exit for
'        End If
'        'remove top folder in path
'        evalPath = RemoveTopFolderFromPath(evalPath)
'    Loop
    
    If oneDrivePathFound = True Then
        result = testFilePath
    Else
        result = vbNullString
        
    End If
    
    GetFilePathByRootFolder = result
    
End Function

公共函数GetFilePathByRootFolder（ByVal RootFolder作为字符串，ByVal SearchPath作为字符串）作为字符串
将结果变暗为字符串
Dim evalPath作为字符串
Dim testFilePath作为字符串
将slashCounter设置为整数“由AC添加”
Dim i作为整数“由AC添加”
Dim oneDrivePathFound为布尔值
evalPath=IIf（InStr（SearchPath，“\”=0，“\”，vbNullString）&SearchPath
slashCounter=0'由AC添加
执行由AC添加的像“*\*”这样的求值路径
slashCounter=slashCounter+1'由AC添加
evalPath=RemoveTopFolderFromPath（evalPath）’由AC添加
由AC添加的“回路”
slashCounter=slashCounter+1
evalPath=IIf（InStr（SearchPath，“\”=0，“\”，vbNullString）&SearchPath
对于由AC添加的“slashCounter”，i=1
testFilePath=RootFolder&IIf（左$（evalPath，1）“\”，“\”，vbNullString）&evalPath'由AC添加
调试。打印AC添加的testFilePath
如果不是（Dir（testFilePath））=vbNullString，则由AC添加
oneDrivePathFound=True'由AC添加
“由AC添加”的退出
如果由AC添加，则结束
AC添加的“删除路径中的顶级文件夹”
evalPath=RemoveTopFolderFromPath（evalPath）’由AC添加
下一个i’由AC添加
'像“*\*”这样的执行While evalPath'将循环更改为“for each\ in evalPath+1”
'testFilePath=RootFolder&IIf（左$（ev）
    Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
    Dim result As String
    Dim evalPath As String
    Dim testFilePath As String
    Dim slashCounter As Integer                                                                         'added by AC
    Dim i As Integer                                                                                    'added by AC
    
    Dim oneDrivePathFound As Boolean
       
    evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
    
    slashCounter = 0                                                                                    'added by AC
    Do While evalPath Like "*\*"                                                                        'added by AC
        slashCounter = slashCounter + 1                                                                 'added by AC
        evalPath = RemoveTopFolderFromPath(evalPath)                                                    'added by AC
    Loop                                                                                                'added by AC
    slashCounter = slashCounter + 1
    evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath

    For i = 1 To slashCounter                                                                           'added by AC
        testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath        'added by AC
        Debug.Print testFilePath                                                                        'added by AC
        If Not (Dir(testFilePath)) = vbNullString Then                                                  'added by AC
            oneDrivePathFound = True                                                                    'added by AC
            Exit For                                                                                    'added by AC
        End If                                                                                          'added by AC
        'remove top folder in path                                                                      'added by AC
        evalPath = RemoveTopFolderFromPath(evalPath)                                                    'added by AC
    Next i                                                                                              'added by AC
    
'    Do While evalPath Like "*\*" ' change loop to "for each \ in evalPath +1"
'        testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
'        Debug.Print testFilePath
'        If Not (Dir(testFilePath)) = vbNullString Then
'            oneDrivePathFound = True
'            Exit Do 'exit for
'        End If
'        'remove top folder in path
'        evalPath = RemoveTopFolderFromPath(evalPath)
'    Loop
    
    If oneDrivePathFound = True Then
        result = testFilePath
    Else
        result = vbNullString
        
    End If
    
    GetFilePathByRootFolder = result
    
End Function