返回Excel VBA宏OneDrive本地路径-可能的线索 [英] Return Excel VBA Macro OneDrive Local Path - Possible Lead

问题描述

我有一个电子表格，很多人都需要访问(在共享点上)，出于某些原因，我们需要在本地进行(同步).

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

这是一个招标登记册，用于输入客户，客户联系人和招标信息，生成报价单号，文件夹和文件名等.

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

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

我已经在上下搜索了使用VBA在共享点上创建文件夹和文件的方法，以及除了禁用使用Office应用程序同步我打开的Office文件"之外与本地路径进行交互的方法.(由于文件协作，此功能是必需的.)当我找到一种将URL转换为本地路径的方法时，我曾抱有希望，但是，这并不是最好的解决方案，因为每个用户都可以在不同级别同步文件夹(也许有人可以帮助我确定路径，一个宏，以便在OneDrive目录中搜索文件夹"2021 Tenders"并返回路径……认为这样做可能会很慢)

但是，我注意到我是否转到文件>信息，这里有一个打开文件位置"按钮.它直接将我带到文件的本地路径文件夹，这告诉我该信息在excel中，必须有一种检索它的方法，在指出任何信息后，我在任何搜索中都没有看到对此的引用，是否有人对它如何运作或是否运作有任何想法?我试图记录一个宏，但是根本没有注册它.

我们将不胜感激，并先谢谢您.

解决方案

这是我根据另一个答案组装而成的内容(请参见代码内部的注释).

代码属于我整理的一系列类，但是为了给您一个 complex 简单答案，请将其放在模块中:

 选项显式私有常量ONEDRIVE_TENANTS_REGISTRY_FOLDER As String ="Software \ Microsoft \ OneDrive \ Accounts \ Business1 \ Tenant \"只要3 =私人常量ONEDRIVE_TOTAL_VERSIONS私有常量ONEDRIVE_PATH_SLASHES只要= 4常量HKEY_CURRENT_USER =& H80000001公共函数GetLocalWorkbookName(ByVal fullName作为字符串，可选的ByVal PathOnly作为Boolean = False)作为字符串积分:https://stackoverflow.com/a/57040668/1521579'返回本地wb路径；如果找不到本地路径，则返回空字符串昏暗的localFolders As Collection昏暗的localFolder作为变体昏暗的evalPath作为字符串结果暗淡为字符串将Dim isOneDrivePath设为布尔值'检查它是否看起来像一个OneDrive位置isOneDrivePath = InStr(1，fullName，"https://"，vbTextCompare)>0如果isOneDrivePath = False，则结果=全名别的设置localFolders = GetLocalFoldersevalPath = RemoveTopFoldersByQty(全名，ONEDRIVE_PATH_SLASHES)对于localFolders中的每个localFolder结果= GetFilePathByRootFolder(localFolder，evalPath)如果结果<>vbNullString然后退出下一个本地文件夹万一如果只有路径GetLocalWorkbookName = RemoveFileNameFromPath(结果)别的GetLocalWorkbookName =结果万一结束功能公共函数GetLocalFolders()作为集合Dim tempCollection作为集合昏暗的租户变暗localFolders作为变体昏暗的租户设置tempCollection =新集合'在onedrive中查找业务租户的文件夹tenantFolders = GetRegistrySubKeys(ONEDRIVE_TENANTS_REGISTRY_FOLDER)对于tenantCounter = 0到UBound(tenantFolders)localFolders = GetRegistryValues(ONEDRIVE_TENANTS_REGISTRY_FOLDER&"\"& tenantFolders(tenantCounter)&"\")AddArrayItemsToCollection tempCollection，localFolders下一个租户'添加onedrive使用者文件夹tempCollection.Add Environ $("OneDriveConsumer")设置GetLocalFolders = tempCollection结束功能公共函数RemoveTopFolderFromPath(ByVal ShortName As String)As StringRemoveTopFolderFromPath = Mid $(ShortName，InStr(ShortName，" \'))+ 1)结束功能公共函数RemoveTopFoldersByQty(ByVal FullPath作为字符串，ByVal FolderQty作为字符串)作为字符串点心柜台昏暗的evalPath作为字符串evalPath = Replace(FullPath，"/"，"\")对于计数器= 1到FolderQtyevalPath = RemoveTopFolderFromPath(evalPath)下一个柜台RemoveTopFoldersByQty = evalPath结束功能公共函数RemoveFileNameFromPath(ByVal ShortName As String)As StringRemoveFileNameFromPath = Mid $(ShortName，1，Len(ShortName)-InStr(StrReverse(ShortName)，"\"))结束功能公共函数GetFilePathByRootFolder(ByVal RootFolder作为字符串，ByVal SearchPath作为字符串)作为字符串结果暗淡为字符串昏暗的evalPath作为字符串昏暗的testFilePath作为字符串将OneDrivePathFound调暗为布尔值evalPath = IIf(InStr(SearchPath，"\")= 0，"\"，vbNullString)&搜索路径在evalPath像"* \ *"一样时执行testFilePath = RootFolder&IIf(Left $(evalPath，1)<>"\"，"\"，vbNullString)&evalPath如果不是(Dir(testFilePath))= vbNullString然后oneDrivePathFound =真退出做万一'删除路径中的顶部文件夹evalPath = RemoveTopFolderFromPath(evalPath)环形如果oneDrivePathFound = True，则结果= testFilePath别的结果= vbNullString万一GetFilePathByRootFolder =结果结束功能公共函数GetRegistrySubKeys(ByVal pathToFolder As String)作为变体积分:https://stackoverflow.com/a/8667984/1521579昏暗的registryObject作为对象昏暗的computerID作为字符串变暗subkeys()作为变体'昏暗的钥匙作为变体computerID =."设置RegistryObject = GetObject(" winmgmts:{impersonationLevel = impersonate}！\\"& _计算机ID和" \ root \ default:StdRegProv")RegistryObject.EnumKey HKEY_CURRENT_USER，pathToFolder，子项GetRegistrySubKeys =子项'对于子键中的每个键'Debug.Print键'下一个结束功能公共函数GetRegistryValues(ByVal pathToFolder As String)作为变体积分:https://stackoverflow.com/a/8667984/1521579昏暗的registryObject作为对象昏暗的computerID作为字符串昏暗的values()作为变体昏暗的valuesTypes()作为变体'昏暗的价值作为变体computerID =."设置RegistryObject = GetObject(" winmgmts:{impersonationLevel = impersonate}！\\"& _计算机ID和" \ root \ default:StdRegProv")RegistryObject.EnumValues HKEY_CURRENT_USER，pathToFolder，值，valuesTypesGetRegistryValues =值'对于每个值'Debug.Print值'下一个结束功能Public Sub AddArrayItemsToCollection(ByVal evalCollection作为Collection，ByVal evalArray作为Variant)变暗的物品作为变体对于evalArray中的每个项目evalCollection.Add项下一项结束子 

并这样称呼它:

 ?GetLocalWorkbookName(ThisWorkbook.fullName，true) 

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

I have a spreadsheet that many people need to access (on sharepoint), for a few reasons, we need to do this locally (synced).

however, there are constantly problems and errors arising due to knowledge levels of each user, the spreadsheet needs to have structure and consistency, so in order to achieve that, i have created a userform with a suite of parameters to help people enter accurate data and avoid errors.

it is a tender register, used to enter client, client contact and tender information, which generates a quote number, folder and file name etc.

prior to OneDrive/Sharepoint path change (previously the file path would be local, now it is a sharepoint URL) i had a macro that would run when a user clicked a button, that would create an appropriately named folder in the relevant local sharepoint directory, create a standard set of folders within that folder (Client Documents, Contract, Product Files, Drawings etc.) then open a Tender Form and save it in the created folder. the filename (the quote number) was used to lookup a query from the Tender register to return all the client/contact/quote information.

since sharepoint has changed it's path protocol from local to URL, i can't get this to work, resulting in a manual process, therefore, resulting in errors and inconsitencies.

i have searched high and low for ways to create folders and files on sharepoint using VBA, and also for ways to interact with the local path other than disabling "Use Office applications to sync Office files that I Open" (this function is required due to file collaboration.) I had one hope when i found a way to convert a URL to a Local path, however, this isn't the best solution as each user syncs folders at different levels (maybe there is a way someone could help me with determining the path, a macro to search in the OneDrive directory for folder "2021 Tenders" and return the path... think this might be slow though)

however, i noticed if i goto File > Info, there is a button for "Open File Location" which takes me directly to the local path folder of the file, which tells me this information is somewhere in excel, there must be a way to retrieve it, i haven't seen reference to this in any of my searches, upon pointing it out, does anyone have any ideas on how or if this could work? i tried to record a macro, but it didn't register it at all.

any help would be appreciated and thank you in advance.

File > Info - Screenshot

解决方案

This is something I assembled based on another answer (see comments inside the code).

Code belongs to a series of classes I put together but in order to give you a complex simple answer, throw this in a module:

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

And call it like this:

? GetLocalWorkbookName(ThisWorkbook.fullName, true)

Hope it helps, let me know if it works

这篇关于返回Excel VBA宏OneDrive本地路径-可能的线索的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！