OneDriveLocalPath

'@Folder "Lib"
Option Explicit
' Compiled code from : https://stackoverflow.com/questions/65605296/return-excel-vba-macro-onedrive-local-path-possible-lead

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
Private 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
Private Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
    RemoveTopFolderFromPath = Mid$(ShortName, InStr(ShortName, "\") + 1)
End Function

Private 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

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

Private 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

    If oneDrivePathFound = True Then
        Result = testFilePath
    Else
        Result = vbNullString

    End If

    GetFilePathByRootFolder = Result

End Function

Private 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

Private 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



Private 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