Return Excel VBA Macro OneDrive Local Path - Possible Lead

Question

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

Answer 1

This worked for me. I used environmental variables.

OneDrive = Environ("OneDrive")
CurPath = Application.ThisWorkbook.Path
If (InStr(1, Left(CurPath, 4), "http", vbTextCompare)) Then
    SubPathPos = InStr(30, CurPath, "/", vbTextCompare)
    CurPath = OneDrive & Right(CurPath, Len(CurPath) - SubPathPos + 1)
End If
ChDir (CurPath)

Answer 2

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

Answer 3

the code worked perfect for files that were in the subfolders of each onedrive/sharepoint root synced folder (top level) but not if the file was in the top level itself

i stepped through the code to see where it filters through each slash and i changed from a "do while" to a "for" in the "GetFilePathByRootFolder" Function. Counting the amount of slashes with your "do while" loop, then doing a "for" loop for the amount of slashes +1 to "RemoveTopFolderFromPath" with an additional run, leaving only the file name for a last search through the root folder for the file name.

hope this makes sense.

    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

Answer 4

Apologies for not commenting directly on @engineercliff code (not enough reputation points):

simple and works, I just replaced "/" for "" at the end to make it work:

OneDrive = Environ("OneDrive")
CurPath = Application.ThisWorkbook.Path
If (InStr(1, Left(CurPath, 4), "http", vbTextCompare)) Then
   SubPathPos = InStr(30, CurPath, "/", vbTextCompare)
   CurPath = OneDrive & Right(CurPath, Len(CurPath) - SubPathPos + 1)
   Curpath = Replace(Curpath, "/", "\")
End If
ChDir (CurPath)