GetLocalPath doesn't work in all cases

[guwidoe]

Hello, I love the work you did with your VBA Libraries!

I recently ran into an issue with my GetLocalPath function, then I remembered yours, gave it a try, and ran into even more issues. The first problem, which only occurred in your function, is that the registry keys you read don't seem to contain information for all of the possible WebPaths. I have these two "Accounts" in my registry, yet only the Business1 one contains a bunch of subkeys, while the Personal one only contains (Standard), so it's completely empty. This is not too big of a surprise, because I'm only logged in on my business account on that machine.

This is a problem, because even if you only have one Business account logged in, there can be at least two (I know of...) different WebPath "roots", one for the "Personal" (Business) OneDrive folder, and one for the "SharePoint" folder. "Personal" (Business) OneDrive "SharePoint" folder

Because you only read one of the possible WebPaths (ServiceEndpointUri), this leaves you with too little information to deal with all possible WebPaths. There is information about the paths in the Registry folder you are checking, but I'm not sure it's enough. I have the keys SPOResourceId -> https://%company_name%online-my.sharepoint.com/ (Personal) TeamSiteSPOResourceId -> https://%company_name%online.sharepoint.com/ (SharePoint)

which contain something like the "roots root" of the two possible WebPaths. But I'm not even sure if reading these would give enough information since the actual SharePoint WebPath has a longer root, something like https://%company_name%online.sharepoint.com/sites/workspaces/ and I don't know if the /sites/workspaces/ is the same in every possible SharePoint WebPath.

This doesn't really matter since I would recommend reading different RegistryKeys anyways, which you know about too I suppose. These are of course located at \HKEY_CURRENT_USER\Software\SyncEngines\Providers\OneDrive Here, reading the UrlNamespace and MountPoint subkeys of all the subfolders gives almost all the necessary information to construct the right local paths, but there is still a little annoyance, which is where I ran into the problem in the first place.

That is if the synchronized folder is not at the base of the folder structure on the server, the WebPath will still contain all the server subfolders which do not exist in the local mount, but the UrlNamespace key will still only contain the "root" of the WebPath. Hence, if we construct a LocalPath by replacing the "root" of the WebPath with the MountPoint and fixing the PathSeparators, the "intermediate" folders which are present in the WebPath will still be present in the constructed (wrong) LocalPath.

The only way I can think of to solve this issue would be constructing the WebPath this way and then checking if the folder/file exists and removing intermediate path parts until the path points to a valid folder/file. Of course, this is not very elegant and takes away the feature of also working for nonexistent files/folders.

Maybe you can come up with a better solution, the missing information should be somewhere out there in the registry, shouldn't it?

[cristianbuse]

Below is the updated code. I hope this passes the 3 tests that were failing before.

Option Explicit

Private Type OneDriveProvider
    cid As String
    urlNamespace As String
    mountPoint As String
    actualFolder As String
    isSet As Boolean
    isBusiness As Boolean
End Type
Private Type OneDriveProviders
    arr() As OneDriveProvider
    pCount As Long
    isSet As Boolean
End Type
Private Enum ProviderFindType
    tCID
    tMount
    tURL
End Enum

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Static providers As OneDriveProviders
    Dim i As Long
    Dim tempURL As String
    Dim rPart As String
    '
    If Not providers.isSet Then providers = GetOneDriveProviders()
    '
    For i = 1 To providers.pCount
        With providers.arr(i)
            tempURL = Left$(odWebPath, Len(.urlNamespace))
            If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
        End With
    Next i
    If i > providers.pCount Then Exit Function
    '
    With providers.arr(i)
        If Not .isSet Then Exit Function
        rPart = Replace(odWebPath, .urlNamespace, vbNullString)
        GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
    End With
End Function

'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
    Const HKCU = &H80000001 'HKEY_CURRENT_USER
    Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
    Const computerName As String = "."
    Dim oReg As Object
    Dim subKeys() As Variant
    Dim subKey As Variant
    Dim i As Long
    '
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
        & computerName & "\root\default:StdRegProv")
    oReg.EnumKey HKCU, regPath, subKeys
    '
    With GetOneDriveProviders
        On Error Resume Next
        .pCount = UBound(subKeys) - LBound(subKeys) + 1
        On Error GoTo 0
        If .pCount = 0 Then Exit Function
        '
        ReDim .arr(1 To .pCount)
        i = 1
        For Each subKey In subKeys
            ReadRegistryProvider oReg, regPath & subKey, .arr(i)
            i = i + 1
        Next subKey
        FixProvidersFromSettings .arr
        .isSet = True
    End With
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
                                    , ByVal regKey As String _
                                    , ByRef provider As OneDriveProvider)
    Const HKCU = &H80000001
    Dim cid As String
    Dim aFolder As String
    Dim relPath As String
    '
    With provider
        oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
        oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
        oReg.GetStringValue HKCU, regKey, "CID", cid
        .cid = FixCID(cid)
        .isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
        If .isBusiness Then
            If Right$(.urlNamespace, 1) = "/" Then
                .urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
            End If
        Else
            oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
            .urlNamespace = .urlNamespace & "/" & .cid
            If LenB(relPath) = 0 Then
                .isSet = True
            Else
                .actualFolder = relPath
                .mountPoint = BuildPath(.mountPoint, relPath)
            End If
        End If
    End With
End Function
Private Function FixCID(ByVal cid As String) As String
    Dim i As Long: i = InStr(1, cid, "!")
    If i = 0 Then FixCID = cid Else FixCID = Left$(cid, i - 1)
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Const personalDatMask As String = "????????????????.dat"
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim iniName As String
    Dim iniPath As String
    Dim datName As String
    Dim datPath As String
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            iniName = Dir(BuildPath(folderPath, businessIniMask))
            If LenB(iniName) > 0 Then
                iniPath = BuildPath(folderPath, iniName)
                datPath = Replace(iniPath, ".ini", ".dat")
                FixBusinessProviders iniPath, datPath, providers
            End If
        ElseIf folderName = "Personal" Then
            iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
            datName = Dir(BuildPath(folderPath, personalDatMask))
            If LenB(datName) > 0 And IsFile(iniPath) Then
                datPath = BuildPath(folderPath, datName)
                FixPersonalProviders iniPath, datPath, providers
            End If
        End If
    Next folderPath
End Sub

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim fileNumber As Long: fileNumber = FreeFile
    Dim lineText As String
    Dim arrParts() As String
    Dim tempMount As String
    Dim tempID As String
    Dim tempFolder As String
    Dim tempURL As String
    Dim i As Long
    Dim collFolders As Collection
    Dim collParents As Collection
    '
    Open iniPath For Input Access Read As #fileNumber
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineText
        '
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 9 Then
                tempMount = arrParts(9)
                If LenB(tempMount) > 0 Then
                    tempURL = arrParts(5)
                    Do
                        i = FindBusinessProvider(providers, tURL, tempURL)
                        If i > 0 Then providers(i).isSet = True
                    Loop Until i = 0
                End If
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then
                Set collFolders = GetODFolders(datPath, collParents)
            End If
            arrParts = Split(lineText, """")
            tempMount = arrParts(1)
            i = FindBusinessProvider(providers, tMount, tempMount)
            If i > 0 Then
                tempID = Split(arrParts(0), " ")(4)
                tempID = Split(tempID, "+")(0)
                tempFolder = vbNullString
                On Error Resume Next
                Do
                    tempFolder = "/" & collFolders(tempID) & tempFolder
                    tempID = collParents(tempID)
                Loop Until Err.Number <> 0
                On Error GoTo 0
                If LenB(tempFolder) > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & tempFolder
                        .isSet = True
                    End With
                End If
            End If
        Case "AddedScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 3 Then
                tempURL = arrParts(1)
                i = FindBusinessProvider(providers, tURL, tempURL)
                If i > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & "/" & arrParts(5)
                        .isSet = True
                    End With
                End If
            End If
        Case Else
            Exit Do
        End Select
    Loop
    Close #fileNumber
End Sub

'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindBusinessProvider(ByRef providers() As OneDriveProvider _
                                    , ByVal findType As ProviderFindType _
                                    , ByVal searchValue As String) As Long
    Dim i As Long
    Dim temp As String
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And .isBusiness Then
                Select Case findType
                    Case tCID:   temp = .cid
                    Case tMount: temp = .mountPoint
                    Case tURL:   temp = Left$(.urlNamespace, Len(searchValue))
                End Select
                If StrComp(temp, searchValue, vbTextCompare) = 0 Then
                    FindBusinessProvider = i
                    Exit Function
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim s As String: s = ReadBytes(iniPath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim lines() As String: lines = Split(s, vbNewLine)
    Dim lineText As Variant
    Dim i As Long
    Dim cid As String
    Dim relPath As String
    Dim folderID As String
    Dim folderName As String
    Dim collFolders As Collection
    '
    For Each lineText In lines
        i = InStr(1, lineText, "_")
        If i > 0 Then
            Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
            Case "BaseUri"
                cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            Case "Path"
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(datPath)
                End If
                If collFolders.Count > 0 Then
                    folderName = collFolders(folderID)
                    i = FindPersonalProvider(providers, cid, folderName)
                    If i > 0 Then
                        With providers(i)
                            .urlNamespace = .urlNamespace & "/" & relPath
                            .isSet = True
                        End With
                    End If
                End If
            End Select
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility for finding a business provider that is not set
'*******************************************************************************
Private Function FindPersonalProvider(ByRef providers() As OneDriveProvider _
                                    , ByRef cid As String _
                                    , ByVal actualFolder As String) As Long
    Dim fCID As String: fCID = FixCID(cid)
    Dim i As Long
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And Not .isBusiness Then
                If StrComp(.actualFolder, actualFolder, vbTextCompare) = 0 Then
                    If StrComp(.cid, cid, vbTextCompare) = 0 _
                    Or StrComp(.cid, fCID, vbTextCompare) = 0 Then
                        FindPersonalProvider = i
                        Exit Function
                    End If
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim s As String: s = ReadBytes(filePath)
    If LenB(s) = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullChar) - i
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullChar) - i
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                folderName = MidB$(s, i, bytes)
                '
                collFolders.Add folderName, folderID
                outParents.Add parentID, folderID
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Function ReadBytes(ByVal filePath As String) As Byte()
    Dim fileNumber As Long:    fileNumber = FreeFile
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim ReadBytes(0 To LOF(fileNumber) - 1)
    Get fileNumber, , ReadBytes
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Function

[guwidoe]

I tested the code and I get an Error at the following line:

Key already exists in the collection...

[cristianbuse]

When the code breaks on error, paste ?folderid,foldername,collFolders(folderid) in the Immediate window and press Enter. What does it display?

[guwidoe]

They are all empty:

[cristianbuse]

Thanks for running all these. I hate asking you to run all these steps just so I can see what's going on.

Is there any chance you could share the whole dat file with me? I am happy to sign a Non-Disclosure agreement if required. Also I am open to other suggestions you might have.

After all, I could just wait until you have a chance to look into this yourself.

Please let me know your thoughts!

[guwidoe]

I'm glad to help, I'm happy to learn new things running these tests for you! If it were my own company I'd gladly share it with you, but in this case, unfortunately, I do not see myself able to share it :(

Also I'm delighted you are trying to solve it because I don't think I would have gotten very far alone, and I think it's a surprisingly difficult, interesting and at the same time relevant problem to which currently no satisfying solution seems to exist.

I looked at and tested every single solution I found online and all of them fail even some quite basic tests.

So as long as you are still interested in solving this, I'll gladly help you debug!

[cristianbuse]

Thanks! I definitely want to see this solved.

Can you run this and share the resulting file? It only gets the folder IDs and preceding 16 bytes to better see what rule is applied.

Option Explicit

Sub DebugAllIDs()
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\Business1"
    Dim settingsPath As String
    Dim iniName As String
    Dim iniPath As String
    Dim datName As String
    Dim filePath As String
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    iniName = Dir(BuildPath(settingsPath, businessIniMask))
    filePath = BuildPath(settingsPath, Replace(iniName, ".ini", ".dat"))
    '
    Dim s As String: s = ReadBytes(filePath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim i As Long
    Dim bytes As Long
    Dim hFolder As String
    Dim hCheck As String
    Dim stepSize As Long
    Dim folderID As String
    Dim parentID As String
    Dim previous As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    '
    stepSize = 16
    i = InStrB(stepSize, s, hCheck)
    Do While i > stepSize
        If MidB$(s, i - stepSize, 1) = hFolder Then
            previous = StrConv(MidB$(s, i - stepSize, stepSize), vbUnicode)
            '
            i = i + 8
            bytes = InStrB(i, s, vbNullByte) - i
            folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
            '
            i = i + 39
            bytes = InStrB(i, s, vbNullByte) - i
            parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
            i = i + 121
            '
            collFolders.Add Join(Array(previous, folderID, parentID), "<>")
        End If
        i = InStrB(i + 1, s, hCheck)
    Loop
    '
    Dim textToSave As String
    Dim v As Variant
    '
    For Each v In collFolders
        textToSave = textToSave & v & vbNewLine
    Next v
    '
    Dim fileNumber As Long: fileNumber = FreeFile
    Dim debugPath As String: debugPath = Environ("USERPROFILE") & "\Desktop\debugAllIDs.txt"
    '
    Open debugPath For Output Access Write As #fileNumber
    Print #fileNumber, textToSave
    Close #fileNumber
    On Error GoTo 0
End Sub
Private Function ReadBytes(ByVal filePath As String) As Byte()
    Dim fileNumber As Long:    fileNumber = FreeFile
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim ReadBytes(0 To LOF(fileNumber) - 1)
    Get fileNumber, , ReadBytes
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Function

[cristianbuse]

Hi @guwidoe ,

My apologies if you're just too busy or away! I was just wondering if you noticed my last comment. I ask because I forgot to tag you and I was thinking that you might have missed it.

Thanks!

[guwidoe]

Hi @cristianbuse,

I'm sorry for my late reply, I was indeed away!

I think the problem is that some IDs appear multiple times with matching signatures and hence some part gets added multiple times to the path, resulting in a wrong output. debugAllIDs.txt

here is the file your script produced!

[cristianbuse]

Thanks @guwidoe ,

I've added some extra safety features. Could you please test the below?

Option Explicit

Private Type OneDriveProvider
    cid As String
    urlNamespace As String
    mountPoint As String
    actualFolder As String
    isSet As Boolean
    isBusiness As Boolean
End Type
Private Type OneDriveProviders
    arr() As OneDriveProvider
    pCount As Long
    isSet As Boolean
End Type
Private Enum ProviderFindType
    tCID
    tMount
    tURL
End Enum

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Static providers As OneDriveProviders
    Dim i As Long
    Dim tempURL As String
    Dim rPart As String
    '
    If Not providers.isSet Then providers = GetOneDriveProviders()
    '
    For i = 1 To providers.pCount
        With providers.arr(i)
            tempURL = Left$(odWebPath, Len(.urlNamespace))
            If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
        End With
    Next i
    If i > providers.pCount Then Exit Function
    '
    With providers.arr(i)
        If Not .isSet Then Exit Function
        rPart = Replace(odWebPath, .urlNamespace, vbNullString)
        GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
    End With
End Function

'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
    Const HKCU = &H80000001 'HKEY_CURRENT_USER
    Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
    Const computerName As String = "."
    Dim oReg As Object
    Dim subKeys() As Variant
    Dim subKey As Variant
    Dim i As Long
    '
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
        & computerName & "\root\default:StdRegProv")
    oReg.EnumKey HKCU, regPath, subKeys
    '
    With GetOneDriveProviders
        On Error Resume Next
        .pCount = UBound(subKeys) - LBound(subKeys) + 1
        On Error GoTo 0
        If .pCount = 0 Then Exit Function
        '
        ReDim .arr(1 To .pCount)
        i = 1
        For Each subKey In subKeys
            ReadRegistryProvider oReg, regPath & subKey, .arr(i)
            i = i + 1
        Next subKey
        FixProvidersFromSettings .arr
        .isSet = True
    End With
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
                                    , ByVal regKey As String _
                                    , ByRef provider As OneDriveProvider)
    Const HKCU = &H80000001
    Dim cid As String
    Dim aFolder As String
    Dim relPath As String
    '
    With provider
        oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
        oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
        oReg.GetStringValue HKCU, regKey, "CID", cid
        .cid = FixCID(cid)
        .isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
        If .isBusiness Then
            If Right$(.urlNamespace, 1) = "/" Then
                .urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
            End If
        Else
            oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
            .urlNamespace = .urlNamespace & "/" & .cid
            If LenB(relPath) = 0 Then
                .isSet = True
            Else
                .actualFolder = relPath
                .mountPoint = BuildPath(.mountPoint, relPath)
            End If
        End If
    End With
End Function
Private Function FixCID(ByVal cid As String) As String
    Dim i As Long: i = InStr(1, cid, "!")
    If i = 0 Then FixCID = cid Else FixCID = Left$(cid, i - 1)
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Const personalDatMask As String = "????????????????.dat"
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim iniName As String
    Dim iniPath As String
    Dim datName As String
    Dim datPath As String
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            iniName = Dir(BuildPath(folderPath, businessIniMask))
            If LenB(iniName) > 0 Then
                iniPath = BuildPath(folderPath, iniName)
                datPath = Replace(iniPath, ".ini", ".dat")
                FixBusinessProviders iniPath, datPath, providers
            End If
        ElseIf folderName = "Personal" Then
            iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
            datName = Dir(BuildPath(folderPath, personalDatMask))
            If LenB(datName) > 0 And IsFile(iniPath) Then
                datPath = BuildPath(folderPath, datName)
                FixPersonalProviders iniPath, datPath, providers
            End If
        End If
    Next folderPath
End Sub

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim fileNumber As Long: fileNumber = FreeFile
    Dim lineText As String
    Dim arrParts() As String
    Dim tempMount As String
    Dim tempID As String
    Dim tempFolder As String
    Dim tempURL As String
    Dim i As Long
    Dim collFolders As Collection
    Dim collParents As Collection
    '
    Open iniPath For Input Access Read As #fileNumber
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineText
        '
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 9 Then
                tempMount = arrParts(9)
                If LenB(tempMount) > 0 Then
                    tempURL = arrParts(5)
                    Do
                        i = FindBusinessProvider(providers, tURL, tempURL)
                        If i > 0 Then providers(i).isSet = True
                    Loop Until i = 0
                End If
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then
                Set collFolders = GetODFolders(datPath, collParents)
            End If
            arrParts = Split(lineText, """")
            tempMount = arrParts(1)
            i = FindBusinessProvider(providers, tMount, tempMount)
            If i > 0 Then
                tempID = Split(arrParts(0), " ")(4)
                tempID = Split(tempID, "+")(0)
                tempFolder = vbNullString
                On Error Resume Next
                Do
                    tempFolder = "/" & collFolders(tempID) & tempFolder
                    tempID = collParents(tempID)
                Loop Until Err.Number <> 0
                On Error GoTo 0
                If LenB(tempFolder) > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & tempFolder
                        .isSet = True
                    End With
                End If
            End If
        Case "AddedScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 3 Then
                tempURL = arrParts(1)
                i = FindBusinessProvider(providers, tURL, tempURL)
                If i > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & "/" & arrParts(5)
                        .isSet = True
                    End With
                End If
            End If
        Case Else
            Exit Do
        End Select
    Loop
    Close #fileNumber
End Sub

'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindBusinessProvider(ByRef providers() As OneDriveProvider _
                                    , ByVal findType As ProviderFindType _
                                    , ByVal searchValue As String) As Long
    Dim i As Long
    Dim temp As String
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And .isBusiness Then
                Select Case findType
                    Case tCID:   temp = .cid
                    Case tMount: temp = .mountPoint
                    Case tURL:   temp = Left$(.urlNamespace, Len(searchValue))
                End Select
                If StrComp(temp, searchValue, vbTextCompare) = 0 Then
                    FindBusinessProvider = i
                    Exit Function
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim s As String: s = ReadBytes(iniPath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim lines() As String: lines = Split(s, vbNewLine)
    Dim lineText As Variant
    Dim i As Long
    Dim cid As String
    Dim relPath As String
    Dim folderID As String
    Dim folderName As String
    Dim collFolders As Collection
    '
    For Each lineText In lines
        i = InStr(1, lineText, "_")
        If i > 0 Then
            Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
            Case "BaseUri"
                cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            Case "Path"
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(datPath)
                End If
                If collFolders.Count > 0 Then
                    folderName = collFolders(folderID)
                    i = FindPersonalProvider(providers, cid, folderName)
                    If i > 0 Then
                        With providers(i)
                            .urlNamespace = .urlNamespace & "/" & relPath
                            .isSet = True
                        End With
                    End If
                End If
            End Select
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility for finding a business provider that is not set
'*******************************************************************************
Private Function FindPersonalProvider(ByRef providers() As OneDriveProvider _
                                    , ByRef cid As String _
                                    , ByVal actualFolder As String) As Long
    Dim fCID As String: fCID = FixCID(cid)
    Dim i As Long
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And Not .isBusiness Then
                If StrComp(.actualFolder, actualFolder, vbTextCompare) = 0 Then
                    If StrComp(.cid, cid, vbTextCompare) = 0 _
                    Or StrComp(.cid, fCID, vbTextCompare) = 0 Then
                        FindPersonalProvider = i
                        Exit Function
                    End If
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim s As String:  s = ReadBytes(filePath)
    Dim size As Long: size = LenB(s)
    If size = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                '
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    collFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Function ReadBytes(ByVal filePath As String) As Byte()
    Dim fileNumber As Long:    fileNumber = FreeFile
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim ReadBytes(0 To LOF(fileNumber) - 1)
    Get fileNumber, , ReadBytes
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Function

[guwidoe]

Hi, with this new version, only 3 tests don't pass:

FAILED Test Personal Business OneDrive shared by someone else (non-existent folder)
URL path: https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Test/
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Test\

FAILED Test Personal Business OneDrive shared by someone else (mounts to SharePoint on local sync!)
URL path: https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Beispiel import.xlsm
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Beispiel import.xlsm

In these two cases, as mentioned in a previous comment, I think the reason is, that for some reason, the ID for this folder appears multiple times with a matching signature in the .dat file:

First occurrence: Second occurrence: Third occurrence: Fourth occurrence: Fifth occurrence:

As you can see, the bytes before occurrence 1,2 and 4 match what we are looking for. therefore, too many parts get added to the urlNamespace:

FAILED Test11 Private SharePoint (Business1 folder name because of supposed cunfusion in the registry, but the registry key just got overwritten)
URL path: https://d.docs.live.net/3dea8a9886f05935/Business1/test.xlsm
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\OneDrive\Business1\test.xlsm

As for this last failed test, I also already explained in a previous comment why it fails. It is an obscure edge case, but I'm sure a solution can be found for it aswell.

I hope this helps!

[cristianbuse]

Thanks @guwidoe ,

The GetODFolders method is actually just picking up the second occurrence because it specifically searches for the preceding x0100...00 which in turn must be preceded by a x02...:

Looking at you Locals window screenshot, makes me wonder if somehow the parent is linking to itself somewhere in the dat file. Could you run the below updated version and see if that fixes the issue:

Option Explicit

Private Type OneDriveProvider
    cid As String
    urlNamespace As String
    mountPoint As String
    actualFolder As String
    isSet As Boolean
    isBusiness As Boolean
End Type
Private Type OneDriveProviders
    arr() As OneDriveProvider
    pCount As Long
    isSet As Boolean
End Type
Private Enum ProviderFindType
    tCID
    tMount
    tURL
End Enum

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Static providers As OneDriveProviders
    Dim i As Long
    Dim tempURL As String
    Dim rPart As String
    '
    If Not providers.isSet Then providers = GetOneDriveProviders()
    '
    For i = 1 To providers.pCount
        With providers.arr(i)
            tempURL = Left$(odWebPath, Len(.urlNamespace))
            If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
        End With
    Next i
    If i > providers.pCount Then Exit Function
    '
    With providers.arr(i)
        If Not .isSet Then Exit Function
        rPart = Replace(odWebPath, .urlNamespace, vbNullString)
        GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
    End With
End Function

'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
    Const HKCU = &H80000001 'HKEY_CURRENT_USER
    Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
    Const computerName As String = "."
    Dim oReg As Object
    Dim subKeys() As Variant
    Dim subKey As Variant
    Dim i As Long
    '
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
        & computerName & "\root\default:StdRegProv")
    oReg.EnumKey HKCU, regPath, subKeys
    '
    With GetOneDriveProviders
        On Error Resume Next
        .pCount = UBound(subKeys) - LBound(subKeys) + 1
        On Error GoTo 0
        If .pCount = 0 Then Exit Function
        '
        ReDim .arr(1 To .pCount)
        i = 1
        For Each subKey In subKeys
            ReadRegistryProvider oReg, regPath & subKey, .arr(i)
            i = i + 1
        Next subKey
        FixProvidersFromSettings .arr
        .isSet = True
    End With
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
                                    , ByVal regKey As String _
                                    , ByRef provider As OneDriveProvider)
    Const HKCU = &H80000001
    Dim cid As String
    Dim aFolder As String
    Dim relPath As String
    '
    With provider
        oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
        oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
        oReg.GetStringValue HKCU, regKey, "CID", cid
        .cid = FixCID(cid)
        .isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
        If .isBusiness Then
            If Right$(.urlNamespace, 1) = "/" Then
                .urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
            End If
        Else
            oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
            .urlNamespace = .urlNamespace & "/" & .cid
            If LenB(relPath) = 0 Then
                .isSet = True
            Else
                .actualFolder = relPath
                .mountPoint = BuildPath(.mountPoint, relPath)
            End If
        End If
    End With
End Function
Private Function FixCID(ByVal cid As String) As String
    Dim i As Long: i = InStr(1, cid, "!")
    If i = 0 Then FixCID = cid Else FixCID = Left$(cid, i - 1)
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Const personalDatMask As String = "????????????????.dat"
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim iniName As String
    Dim iniPath As String
    Dim datName As String
    Dim datPath As String
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            iniName = Dir(BuildPath(folderPath, businessIniMask))
            If LenB(iniName) > 0 Then
                iniPath = BuildPath(folderPath, iniName)
                datPath = Replace(iniPath, ".ini", ".dat")
                FixBusinessProviders iniPath, datPath, providers
            End If
        ElseIf folderName = "Personal" Then
            iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
            datName = Dir(BuildPath(folderPath, personalDatMask))
            If LenB(datName) > 0 And IsFile(iniPath) Then
                datPath = BuildPath(folderPath, datName)
                FixPersonalProviders iniPath, datPath, providers
            End If
        End If
    Next folderPath
End Sub

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim fileNumber As Long: fileNumber = FreeFile
    Dim lineText As String
    Dim arrParts() As String
    Dim tempMount As String
    Dim tempID As String
    Dim prevID As String
    Dim tempFolder As String
    Dim tempURL As String
    Dim i As Long
    Dim collFolders As Collection
    Dim collParents As Collection
    '
    Open iniPath For Input Access Read As #fileNumber
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineText
        '
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 9 Then
                tempMount = arrParts(9)
                If LenB(tempMount) > 0 Then
                    tempURL = arrParts(5)
                    Do
                        i = FindBusinessProvider(providers, tURL, tempURL)
                        If i > 0 Then providers(i).isSet = True
                    Loop Until i = 0
                End If
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then
                Set collFolders = GetODFolders(datPath, collParents)
            End If
            arrParts = Split(lineText, """")
            tempMount = arrParts(1)
            i = FindBusinessProvider(providers, tMount, tempMount)
            If i > 0 Then
                tempID = Split(arrParts(0), " ")(4)
                tempID = Split(tempID, "+")(0)
                tempFolder = vbNullString
                On Error Resume Next
                Do
                    tempFolder = "/" & collFolders(tempID) & tempFolder
                    prevID = tempID
                    tempID = collParents(tempID)
                Loop Until Err.Number <> 0 Or prevID = tempID
                On Error GoTo 0
                If LenB(tempFolder) > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & tempFolder
                        .isSet = True
                    End With
                End If
            End If
        Case "AddedScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 3 Then
                tempURL = arrParts(1)
                i = FindBusinessProvider(providers, tURL, tempURL)
                If i > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & "/" & arrParts(5)
                        .isSet = True
                    End With
                End If
            End If
        Case Else
            Exit Do
        End Select
    Loop
    Close #fileNumber
End Sub

'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindBusinessProvider(ByRef providers() As OneDriveProvider _
                                    , ByVal findType As ProviderFindType _
                                    , ByVal searchValue As String) As Long
    Dim i As Long
    Dim temp As String
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And .isBusiness Then
                Select Case findType
                    Case tCID:   temp = .cid
                    Case tMount: temp = .mountPoint
                    Case tURL:   temp = Left$(.urlNamespace, Len(searchValue))
                End Select
                If StrComp(temp, searchValue, vbTextCompare) = 0 Then
                    FindBusinessProvider = i
                    Exit Function
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim s As String: s = ReadBytes(iniPath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim lines() As String: lines = Split(s, vbNewLine)
    Dim lineText As Variant
    Dim i As Long
    Dim cid As String
    Dim relPath As String
    Dim folderID As String
    Dim folderName As String
    Dim collFolders As Collection
    '
    For Each lineText In lines
        i = InStr(1, lineText, "_")
        If i > 0 Then
            Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
            Case "BaseUri"
                cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            Case "Path"
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(datPath)
                End If
                If collFolders.Count > 0 Then
                    folderName = collFolders(folderID)
                    i = FindPersonalProvider(providers, cid, folderName)
                    If i > 0 Then
                        With providers(i)
                            .urlNamespace = .urlNamespace & "/" & relPath
                            .isSet = True
                        End With
                    End If
                End If
            End Select
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility for finding a business provider that is not set
'*******************************************************************************
Private Function FindPersonalProvider(ByRef providers() As OneDriveProvider _
                                    , ByRef cid As String _
                                    , ByVal actualFolder As String) As Long
    Dim fCID As String: fCID = FixCID(cid)
    Dim i As Long
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And Not .isBusiness Then
                If StrComp(.actualFolder, actualFolder, vbTextCompare) = 0 Then
                    If StrComp(.cid, cid, vbTextCompare) = 0 _
                    Or StrComp(.cid, fCID, vbTextCompare) = 0 Then
                        FindPersonalProvider = i
                        Exit Function
                    End If
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim s As String:  s = ReadBytes(filePath)
    Dim size As Long: size = LenB(s)
    If size = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                '
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    collFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Function ReadBytes(ByVal filePath As String) As Byte()
    Dim fileNumber As Long:    fileNumber = FreeFile
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim ReadBytes(0 To LOF(fileNumber) - 1)
    Get fileNumber, , ReadBytes
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Function

I've basically updated only the Do loop under the "libraryFolder" case of the FixBusinessProviders method.

As for the last failed test, I haven't looked into yet but I know you've explained it in a previous comment. I was saving that for last as I think the priority is to fix the other cases.

Many thanks!

[guwidoe]

@cristianbuse

Thanks for the explanations! I ran your updated version and unfortunately nothing changed regarding the tests. The providers.arr(11) still looks the same too. Let me know if you have and other ideas what to change, unfortunately I'm very busy right now and can't work on it on my own.

[cristianbuse]

Hi @guwidoe ,

Forgot to reply to this. I am out of ideas. As you can see, without access to your files/registry I am literally wasting time and I am also wasting your time. Will wait until you get a chance to look into this.

Thanks again for all your help!

[guwidoe]

Hi @cristianbuse,

I just wanted to let you know I'm working on a solution now. I will update this post as I go and share my finds with you and eventually post a function that (hopefully) will pass all my tests.

I've now been working on extracting the folders from the .dat files. My Business1 dat file is very large (~150MB) so contains lots of potential pitfalls for a folder extraction function. Using the signatures you have been using, some false sections of the file are picked up. For instance this: or this:

I found the culprit! See my next comment

[guwidoe]

I think I may finally have a solution!

IT WASN'T OUR CODE, IT WAS MY TEST THAT WAS WRONG!

My colleague who shared the folder I synced for this test scenario must have moved it inside of his personal OneDrive and it seems like he added two layers of "Guido" folders! I'm very sorry for not figuring that out sooner!

I have now updated the tests and now your function passes these annoying two tests without issues. There are some others, though, which it still fails on: It now passes 29/32 Tests. These are the failed ones, they should be pretty straightforward for you to fix!

FAILED Test Private OneDrive folder
URL path: https://d.docs.live.net/f1189d8c9189d493/Testfolder_toplvl/test.xlsm
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\OneDrive\Testfolder_toplvl\test.xlsm

FAILED Test different private account sync
URL path: https://d.docs.live.net/f1189d8c9189d493/The X Company/Test/Test/Test/test.xlsm
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\OneDrive\The X Company\Test\Test\Test\test.xlsm

FAILED Private OneDrive Folder synced from someone else called "Personal" (confusion in the registry!)
URL path: https://d.docs.live.net/3dea8a9886f05935/Personal/test.xlsm
Func ret: 
act path: C:\Users\Witt-DörringGuidoABC\OneDrive\Personal\test.xlsm

One of the tests that your current solution fails is a new one I came up with. I synchronized a folder called "Personal" shared by someone else's private OneDrive onto my private OneDrive. This can mess the Registry up a little bit.

Maybe this screenshot of my registry has some value for you: I would recommend not using the registry for Personal OneDrive at all, to avoid these Registry confusion edge cases.

This is my function, it passes all my tests. Please let me know if it also passes all your tests!

Public Function GetLocalPath(ByVal Path As String, _
                              Optional ByVal rebuildCache As Boolean = False) _
                              As String
#If Mac Then
    GetLocalPath = Path
    Exit Function
#End If

    Dim webRoot As String
    Dim vKey As Variant
    Static WebToLocDict As Object

    If Not WebToLocDict Is Nothing And Not rebuildCache Then
        For Each vKey In WebToLocDict.Keys
            If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
                Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
                GetLocalPath = Replace(Path, "/", "\")
                Exit Function
            End If
        Next vKey
        GetLocalPath = Path
        Exit Function
    End If

    Const HKCU = &H80000001
    Const computerName As String = "."

    Dim objReg As Object
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
                            computerName & "\root\default:StdRegProv")

    Dim regPath As String
    regPath = "Software\SyncEngines\Providers\OneDrive\"

    Dim LocToWebDict As Object
    Set LocToWebDict = CreateObject("Scripting.Dictionary")

    Dim cid As String
    Dim libType As String

    Dim locRoot As String
    Dim subKeys() As Variant
    Dim subKey As Variant

    'Initializing the dict from the registry:
    objReg.EnumKey HKCU, regPath, subKeys
    'First add all the Business OneDrive MountPoints
    For Each subKey In subKeys
        objReg.GetStringValue HKCU, regPath & subKey, "UrlNamespace", webRoot
        objReg.GetStringValue HKCU, regPath & subKey, "MountPoint", locRoot
        objReg.GetStringValue HKCU, regPath & subKey, "CID", cid
        objReg.GetStringValue HKCU, regPath & subKey, "LibraryType", libType

        'NOTE: For personal OneDrive folders, this way of adding the MountPoints
        'is too risky. There can be various reasons why these registry keys
        'can contain mistakes, like:
        '1. Synchronizing a folder called "Personal" from someone elses personal
        '   OneDrive
        '2. Synchronizing a folder called "Business1" from someone elses personal
        '   OneDrive and then relogging your own first Business OneDrive
        '3. Relogging you own personal OneDrive can change the "CID" property
        '   from a folderID formatted cid (e.g. 3DEA8A9886F05935!125) to a
        '   regular private cid (e.g. 3dea8a9886f05935) for synced folders
        '   from other people's OneDrives
        If libType <> "personal" Then LocToWebDict(locRoot) = webRoot
    Next subKey

    Dim fileNumber As Long
    Dim lineText As String
    Dim lineParts() As String

    Dim bytes() As Byte
    Dim byteStr As String: byteStr = ""
    Dim datFileFolders As Object
    Dim pos As Long, str As String
    Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
    Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
    Dim parentID As String, folderID As String, folderName As String
    Dim lenFolderName As Long

    Dim dirName As String
    Dim settPath As String

    objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
    settPath = settPath & "\Microsoft\OneDrive\settings\"
    regPath = "Software\Microsoft\OneDrive\Accounts\"

    Dim PersGroupFoldersIniExists As Boolean: PersGroupFoldersIniExists = _
        (Dir(settPath & "Personal\GroupFolders.ini") <> "")

    'Refining the dict using the relevant .ini files in the OneDrive settings:
    dirName = Dir(settPath, vbDirectory)
    Do Until dirName = ""
        Select Case True
        'At most, 9 Business OneDrive accounts can be signed in at once.
        Case dirName Like "Business#"
            objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
            If cid = "" Then GoTo NextFolder
            fileNumber = FreeFile
            Open settPath & dirName & "\" & cid & ".dat" For _
                Binary Access Read As #fileNumber
            ReDim bytes(0 To LOF(fileNumber) - 1)
            Get fileNumber, , bytes: byteStr = bytes
            Close #fileNumber: fileNumber = 0
            Set datFileFolders = CreateObject("Scripting.Dictionary")
            pos = InStrB(1, byteStr, sig1)
            Do Until pos = 0
                If InStrB(pos, byteStr, sig2) - pos = 16 Then
                    folderID = StrConv(MidB(byteStr, pos + 24, 32), vbUnicode)
                    parentID = StrConv(MidB(byteStr, pos + 63, 32), vbUnicode)
                    lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
                                    vbNullChar) - (pos + 184)) / 2) * 2
                    folderName = MidB(byteStr, pos + 184, lenFolderName)
                    If folderID Like "[a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9]" Then
                        datFileFolders.Add Key:=folderID, _
                                           Item:=Array(parentID, folderName)
                    End If
                End If
                pos = InStrB(pos + 1, byteStr, sig1)
            Loop

            fileNumber = FreeFile
            Open settPath & dirName & "\" & cid & ".ini" For _
                Input Access Read As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                Select Case left$(lineText, InStr(lineText, " = ") - 1)
                Case "libraryScope"
                    'No change to dict necessary
                Case "libraryFolder"
                    locRoot = Split(lineText, """")(1)
                    parentID = left(Split(lineText, " ")(4), 32)
                    For Each vKey In LocToWebDict.Keys
                        If vKey = locRoot Then
                            Do Until Not datFileFolders.Exists(parentID)
                                str = datFileFolders(parentID)(1) & "/" & str
                                parentID = datFileFolders(parentID)(0)
                            Loop
                            LocToWebDict(vKey) = LocToWebDict(vKey) & str
                            str = ""
                            Exit For
                        End If
                    Next vKey
                Case "AddedScope"
                    lineParts = Split(lineText, """")
                    For Each vKey In LocToWebDict.Keys
                        webRoot = LocToWebDict(vKey)
                        If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
                        1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
                        datFileFolders(left(Split(lineText, " ")(3), 32))(1) Then
                            LocToWebDict(vKey) = LocToWebDict(vKey) & _
                                                 lineParts(5)
                            Exit For
                        End If
                    Next vKey
                Case Else
                    Exit Do
                End Select
            Loop
            Close #fileNumber: fileNumber = 0
            On Error GoTo 0
        'Only one Personal OneDrive account can be signed in at a time.
        Case dirName = "Personal"
            'Adding personal root folder to the translation dict before going
            'into the settings files to finalize the translation dict
            objReg.GetStringValue HKCU, "Software\SyncEngines\Providers\" & _
                                  "OneDrive\Personal", "UrlNamespace", webRoot
            objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
            objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
            If cid = "" Then GoTo NextFolder

            LocToWebDict(locRoot) = webRoot & "/" & cid

            If Not PersGroupFoldersIniExists Then GoTo NextFolder
            fileNumber = FreeFile
            Open settPath & dirName & "\" & cid & ".dat" For _
                Binary Access Read As #fileNumber
            ReDim bytes(0 To LOF(fileNumber) - 1)
            Get fileNumber, , bytes: byteStr = bytes
            Close #fileNumber: fileNumber = 0
            Set datFileFolders = CreateObject("Scripting.Dictionary")
            pos = InStrB(1, byteStr, sig1)
            Do Until pos = 0
                If InStrB(pos, byteStr, sig2) - pos = 16 Then
                    folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
                                                vbUnicode), vbNullChar, "")
                    parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
                                                vbUnicode), vbNullChar, "")
                    lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
                                    vbNullChar) - (pos + 184)) / 2) * 2
                    folderName = MidB(byteStr, pos + 184, lenFolderName)
                    If folderID Like "[A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9]![0-9][0-9][0-9]*" Then
                        datFileFolders.Add Key:=folderID, _
                                           Item:=Array(parentID, folderName)
                    End If
                End If
                pos = InStrB(pos + 1, byteStr, sig1)
            Loop

            cid = ""
            fileNumber = FreeFile
            Open settPath & dirName & "\GroupFolders.ini" For _
                Input Access Read As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                If InStr(lineText, "BaseUri = https://") And cid = "" Then
                    cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
                    folderID = left(lineText, InStr(lineText, "_") - 1)
                ElseIf cid <> "" Then
                    LocToWebDict.Add Key:=locRoot & "\" & _
                                          datFileFolders(folderID)(1), _
                                     Item:=webRoot & "/" & cid & "/" & _
                                    Replace(lineText, folderID & "_Path = ", "")
                    cid = "": folderID = ""
                End If
            Loop
            Close #fileNumber: fileNumber = 0
            On Error GoTo 0
        Case Else
        End Select
NextFolder:
        byteStr = ""
        Set datFileFolders = Nothing
        dirName = Dir
    Loop

    Set WebToLocDict = Nothing
    Set WebToLocDict = CreateObject("Scripting.Dictionary")
    For Each vKey In LocToWebDict.Keys
        locRoot = vKey
        webRoot = LocToWebDict(vKey)
        If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
        If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
        WebToLocDict.Add Key:=webRoot, Item:=locRoot
    Next vKey

    GetLocalPath = GetLocalPath(Path, False)
    Exit Function
CloseFile:
    If fileNumber <> 0 Then: Close #fileNumber
    If fileNumber <> 0 Then: Close #fileNumber
    err.Raise err
End Function

[cristianbuse]

Hi @guwidoe ,

This is excellent news. It does pass all my tests as well. Thank you very much for all your help! I could not have done this without you. I will surely mention your name and link to this issue at the top of the function signature.

While sometimes a long function is the way to go, in this case I would definitely split it up. In my view it is too difficult to maintain and hard to grasp for someone looking at it for the first time. While I do understand it works very well for you and it is more efficient due to less stack frames, I would like to make it easier to digest for any future users of this repository. Your function has a cyclomatic complexity of 21 and 7 nesting levels and so hard to grasp by most people.

Moreover, I would like to use the cache to convert from local path to OneDrive path (as I already do in the repo, although clearly wrong as it is) and so the cache must sit outside of the 2 functions using the cache: GetLocalPath and GetWebPath. One more reason to split.

Once I update the repository, I hope you can test it one more time to be sure I haven't messed anything up.

Many thanks, Cristian

[cristianbuse]

Hi @guwidoe ,

Before I update the repository, I want to refactor my code. I will consider using a dictionary like you did (or 2 collections) and might skip reading the registry for the Personal providers.

However, I want to be sure that I got what the issue was. I basically added a new section to the GetOneDriveProviders function to add a separate provider in case a Personal folder was synchronized as well. Can you please test the below?

Option Explicit

Private Type OneDriveProvider
    cid As String
    urlNamespace As String
    mountPoint As String
    actualFolder As String
    isSet As Boolean
    isBusiness As Boolean
End Type
Private Type OneDriveProviders
    arr() As OneDriveProvider
    pCount As Long
    isSet As Boolean
End Type
Private Enum ProviderFindType
    tCID
    tMount
    tURL
End Enum

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Static providers As OneDriveProviders
    Dim i As Long
    Dim tempURL As String
    Dim rPart As String
    '
    If Not providers.isSet Then providers = GetOneDriveProviders()
    '
    For i = 1 To providers.pCount
        With providers.arr(i)
            tempURL = Left$(odWebPath, Len(.urlNamespace))
            If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
        End With
    Next i
    If i > providers.pCount Then Exit Function
    '
    With providers.arr(i)
        If Not .isSet Then Exit Function
        rPart = Replace(odWebPath, .urlNamespace, vbNullString)
        GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
    End With
End Function

'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
    Const HKCU = &H80000001 'HKEY_CURRENT_USER
    Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
    Const computerName As String = "."
    Dim oReg As Object
    Dim subKeys() As Variant
    Dim subKey As Variant
    Dim i As Long
    Static extraPersonal As Boolean
    '
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
        & computerName & "\root\default:StdRegProv")
    oReg.EnumKey HKCU, regPath, subKeys
    '
    With GetOneDriveProviders
        On Error Resume Next
        .pCount = UBound(subKeys) - LBound(subKeys) + 1
        On Error GoTo 0
        If .pCount = 0 Then Exit Function
        '
        ReDim .arr(1 To .pCount)
        i = 1
        For Each subKey In subKeys
            ReadRegistryProvider oReg, regPath & subKey, .arr(i)
            If .arr(i).actualFolder = "Personal" And Not .arr(i).isBusiness And Not extraPersonal Then
                Dim n As Long: n = .pCount + 1
                Const regKey = "Software\Microsoft\OneDrive\Accounts\Personal"
                '
                ReDim Preserve .arr(1 To n)
                oReg.GetStringValue HKCU, regKey, "cid", .arr(n).cid
                oReg.GetStringValue HKCU, regKey, "UserFolder", .arr(n).mountPoint
                .arr(n).urlNamespace = Replace(.arr(i).urlNamespace, .arr(i).cid, .arr(n).cid)
                .arr(n).isSet = True
                extraPersonal = True
            End If
            i = i + 1
        Next subKey
        FixProvidersFromSettings .arr
        .isSet = True
    End With
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
                                    , ByVal regKey As String _
                                    , ByRef provider As OneDriveProvider)
    Const HKCU = &H80000001
    Dim cid As String
    Dim aFolder As String
    Dim relPath As String
    '
    With provider
        oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
        oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
        oReg.GetStringValue HKCU, regKey, "CID", cid
        .cid = FixCID(cid)
        .isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
        If .isBusiness Then
            If Right$(.urlNamespace, 1) = "/" Then
                .urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
            End If
        Else
            oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
            .urlNamespace = .urlNamespace & "/" & .cid
            If LenB(relPath) = 0 Then
                .isSet = True
            Else
                .actualFolder = relPath
                .mountPoint = BuildPath(.mountPoint, relPath)
            End If
        End If
    End With
End Function
Private Function FixCID(ByVal cid As String) As String
    Dim i As Long: i = InStr(1, cid, "!")
    If i = 0 Then FixCID = cid Else FixCID = Left$(cid, i - 1)
End Function

'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Const personalDatMask As String = "????????????????.dat"
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim iniName As String
    Dim iniPath As String
    Dim datName As String
    Dim datPath As String
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            iniName = Dir(BuildPath(folderPath, businessIniMask))
            If LenB(iniName) > 0 Then
                iniPath = BuildPath(folderPath, iniName)
                datPath = Replace(iniPath, ".ini", ".dat")
                FixBusinessProviders iniPath, datPath, providers
            End If
        ElseIf folderName = "Personal" Then
            iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
            datName = Dir(BuildPath(folderPath, personalDatMask))
            If LenB(datName) > 0 And IsFile(iniPath) Then
                datPath = BuildPath(folderPath, datName)
                FixPersonalProviders iniPath, datPath, providers
            End If
        End If
    Next folderPath
End Sub

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim fileNumber As Long: fileNumber = FreeFile
    Dim lineText As String
    Dim arrParts() As String
    Dim tempMount As String
    Dim tempID As String
    Dim prevID As String
    Dim tempFolder As String
    Dim tempURL As String
    Dim i As Long
    Dim collFolders As Collection
    Dim collParents As Collection
    '
    Open iniPath For Input Access Read As #fileNumber
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineText
        '
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 9 Then
                tempMount = arrParts(9)
                If LenB(tempMount) > 0 Then
                    tempURL = arrParts(5)
                    Do
                        i = FindBusinessProvider(providers, tURL, tempURL)
                        If i > 0 Then providers(i).isSet = True
                    Loop Until i = 0
                End If
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then
                Set collFolders = GetODFolders(datPath, collParents)
            End If
            arrParts = Split(lineText, """")
            tempMount = arrParts(1)
            i = FindBusinessProvider(providers, tMount, tempMount)
            If i > 0 Then
                tempID = Split(arrParts(0), " ")(4)
                tempID = Split(tempID, "+")(0)
                tempFolder = vbNullString
                On Error Resume Next
                Do
                    tempFolder = "/" & collFolders(tempID) & tempFolder
                    prevID = tempID
                    tempID = collParents(tempID)
                Loop Until Err.Number <> 0 Or prevID = tempID
                On Error GoTo 0
                If LenB(tempFolder) > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & tempFolder
                        .isSet = True
                    End With
                End If
            End If
        Case "AddedScope"
            arrParts = Split(lineText, """")
            If UBound(arrParts) >= 3 Then
                tempURL = arrParts(1)
                i = FindBusinessProvider(providers, tURL, tempURL)
                If i > 0 Then
                    With providers(i)
                        .urlNamespace = .urlNamespace & "/" & arrParts(5)
                        .isSet = True
                    End With
                End If
            End If
        Case Else
            Exit Do
        End Select
    Loop
    Close #fileNumber
End Sub

'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindBusinessProvider(ByRef providers() As OneDriveProvider _
                                    , ByVal findType As ProviderFindType _
                                    , ByVal searchValue As String) As Long
    Dim i As Long
    Dim temp As String
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And .isBusiness Then
                Select Case findType
                    Case tCID:   temp = .cid
                    Case tMount: temp = .mountPoint
                    Case tURL:   temp = Left$(.urlNamespace, Len(searchValue))
                End Select
                If StrComp(temp, searchValue, vbTextCompare) = 0 Then
                    FindBusinessProvider = i
                    Exit Function
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim s As String: s = ReadBytes(iniPath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim lines() As String: lines = Split(s, vbNewLine)
    Dim lineText As Variant
    Dim i As Long
    Dim cid As String
    Dim relPath As String
    Dim folderID As String
    Dim folderName As String
    Dim collFolders As Collection
    '
    For Each lineText In lines
        i = InStr(1, lineText, "_")
        If i > 0 Then
            Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
            Case "BaseUri"
                cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            Case "Path"
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(datPath)
                End If
                If collFolders.Count > 0 Then
                    folderName = collFolders(folderID)
                    i = FindPersonalProvider(providers, cid, folderName)
                    If i > 0 Then
                        With providers(i)
                            .urlNamespace = .urlNamespace & "/" & relPath
                            .isSet = True
                        End With
                    End If
                End If
            End Select
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility for finding a business provider that is not set
'*******************************************************************************
Private Function FindPersonalProvider(ByRef providers() As OneDriveProvider _
                                    , ByRef cid As String _
                                    , ByVal actualFolder As String) As Long
    Dim fCID As String: fCID = FixCID(cid)
    Dim i As Long
    For i = LBound(providers) To UBound(providers)
        With providers(i)
            If Not .isSet And Not .isBusiness Then
                If StrComp(.actualFolder, actualFolder, vbTextCompare) = 0 Then
                    If StrComp(.cid, cid, vbTextCompare) = 0 _
                    Or StrComp(.cid, fCID, vbTextCompare) = 0 Then
                        FindPersonalProvider = i
                        Exit Function
                    End If
                End If
            End If
        End With
    Next i
End Function

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim s As String:  s = ReadBytes(filePath)
    Dim size As Long: size = LenB(s)
    If size = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                '
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    collFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Function ReadBytes(ByVal filePath As String) As Byte()
    Dim fileNumber As Long:    fileNumber = FreeFile
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim ReadBytes(0 To LOF(fileNumber) - 1)
    Get fileNumber, , ReadBytes
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Function

[guwidoe]

Hi @cristianbuse

While sometimes a long function is the way to go, in this case I would definitely split it up. In my view it is too difficult to maintain and hard to grasp for someone looking at it for the first time. While I do understand it works very well for you and it is more efficient due to less stack frames, I would like to make it easier to digest for any future users of this repository. Your function has a cyclomatic complexity of 21 and 7 nesting levels and so hard to grasp by most people.

I 100% agree with you. In addition to this, it has some duplicate code that would be much easier to avoid using multiple routines. It was never meant to replace your much more elegant approach of an interconnected library solving many problems at once.

The reason for me trying so hard to do this in a single function is a little bit of an emotional one, and I wasn't aiming to write the most readable code. Let me try to explain. The problem we're trying to solve here Is very common, as well as very isolated. What I mean by this is, very often someone needs a solution for this specific problem and nothing else. There are probably many people who are stumped by this every single day. Usually what you do in such a case is consult the web, take some solution you find and move on with your life. You don't have to understand how the solution works. But here is the thing: In this case, this doesn't work. I wrote an automated testing framework, that let me test solutions I found online relatively quickly and all at once. Let me share the results of these tests with you:

Testing Solution by Gustav Brock, Cactus Data ApS, CPH, 2021-12-29 (https://stackoverflow.com/a/70521246/12287457)
8/32 Tests passed in 6,324219 seconds.

Testing Solution by Iksi (https://stackoverflow.com/a/68963896/12287457)
8/32 Tests passed in 6,613281 seconds.

Testing Solution by Peter G. Schild (https://stackoverflow.com/a/60990170/12287457)
2/32 Tests passed in 0,003906 seconds.

Testing Solution by Alain YARDIM (https://stackoverflow.com/a/65967886/12287457)
2/32 Tests passed in 0,003906 seconds.

Testing Solution by RMK (https://stackoverflow.com/a/67697487/12287457)
4/32 Tests passed in 5,820313 seconds.

Testing Solution by Virtuoso (https://stackoverflow.com/a/33935405/12287457)
4/32 Tests passed in 0,035156 seconds.

Testing Solution by TWMIC (https://stackoverflow.com/a/64591370/12287457)
3/32 Tests passed in 0,117188 seconds.

Testing Solution by Christoph Ackermann (https://stackoverflow.com/a/62742852/12287457)
7/32 Tests passed in 0,179688 seconds.

Testing Solution by Horoman 29.03.2020, main parts by Philip Swannell 14.01.2019, parts from MatChrupczalski 19.05.2019, using environment variables of OneDrive (https://stackoverflow.com/a/60921115/12287457)
4/32 Tests passed in 0,007813 seconds.

Testing Solution by Philip Swannell (https://stackoverflow.com/a/54182663/12287457)
4/32 Tests passed in 0,003906 seconds.

Testing Solution by Schoentalegg (https://stackoverflow.com/a/57040668/12287457)
9/32 Tests passed in 0,011719 seconds.

Testing Solution by tsdn (https://stackoverflow.com/a/56326922/12287457)
2/32 Tests passed in 0,011719 seconds.

Testing Solution by COG (https://stackoverflow.com/a/51316641/12287457)
4/32 Tests passed in 0,027344 seconds.

Testing Solution by beerockxs (https://stackoverflow.com/a/67582367/12287457)
4/32 Tests passed in 4,929688 seconds.

Testing Solution by Erik van der Neut (https://stackoverflow.com/a/72709568/12287457)
6/32 Tests passed in 4,953125 seconds.

Testing Solution by Koen Rijnsent (https://stackoverflow.com/a/71753164/12287457)
0/32 Tests passed in 30,597660 seconds.

Testing Solution by Cooz2 adapted for excel by LucasHol(https://social.msdn.microsoft.com/Forums/office/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive)
0/32 Tests passed in 0,015625 seconds.

Testing Solution by MatChrupczalski (https://social.msdn.microsoft.com/Forums/office/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive)
2/32 Tests passed in 0,050781 seconds.

Testing Solution by Claude (https://stackoverflow.com/a/64657459/12287457)
0/32 Tests passed in 0,000000 seconds.

Testing Solution by Ricardo Diaz (https://stackoverflow.com/a/65605893/12287457)
8/32 Tests passed in 2,644531 seconds.

Testing Solution by Ricardo Gerbaudo (https://stackoverflow.com/a/69929678/12287457)
9/32 Tests passed in 17,320310 seconds.

Testing Solution by Variatus (https://stackoverflow.com/a/68568909/12287457)
0/32 Tests passed in 0,003906 seconds.

Testing Solution by Erlandsen Data Consulting (https://www.erlandsendata.no/?t=vbatips&c=recent&p=4079)
6/32 Tests passed in 0,000000 seconds.

Testing Solution by Ion Cristian Buse (https://github.com/cristianbuse/VBA-FileTools/issues/1)
29/32 Tests passed in 2,597656 seconds.

Testing Ultra-short solution written by Guido Witt-Dörring
19/32 Tests passed in 6,582031 seconds.

Testing Short solution written by Guido Witt-Dörring
19/32 Tests passed in 5,156250 seconds.

Testing Medium solution written by Guido Witt-Dörring
19/32 Tests passed in 6,335938 seconds.

Testing Solution by Guido Witt-Dörring
32/32 Tests passed in 2,308594 seconds.

All tests finished.

As you can see, there doesn't exist a single solution out there (apart from ours) that comes even remotely close to being reliable. In fact, the best other solution passes 9/32 Tests. In case you are wondering what my Ultra-short solution is: it's an adapted version of the first solution I posted in this thread, and it's kind of my code-golf attempt at this problem:

''Ultra-short solution written by Guido Witt-Dörring
Public Function GetLocalPath(ByVal f As String) As String
    Const H = &H80000001
    Dim o As Object, r As String, s(), k, u As String, m As String, p As String
    Set o = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    r = "Software\SyncEngines\Providers\OneDrive\": o.EnumKey H, r, s
    For Each k In s
        o.GetStringValue H, r & k, "UrlNamespace", u
        If InStr(f, u) > 0 Then
            o.GetStringValue H, r & k, "MountPoint", m
            p = Replace(Mid(f, Len(u)), "/", "\"): f = m & p
            Do Until Dir(f, 16) <> "" Or InStr(2, p, "\") = 0
                p = Mid(p, InStr(2, p, "\")): f = m & p
            Loop
            Exit For
        End If
    Next
    GetLocalPath = f
End Function

I must say I'm quite proud of this, as it obliterates any other solution I could find online in terms of accuracy in just 15 lines of code. Even without the "obfuscated" variable names, it's still very, very short:

'Short solution written by Guido Witt-Dörring
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}!\\.\root\default:StdRegProv")
    rPath = "Software\SyncEngines\Providers\OneDrive\"

    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

This "Short solution" is the one I currently use when I actually need a GetLocalPath function. It works in pretty much all real-world scenarios and its simplicity makes it a little less likely to break in the future, in my opinion.

Back to the reason why I tried to write everything into a single function: As you can see, no satisfying solution existed on the web. Many people need this, and only this. They want something to copy and paste that should work. (That's what I want at least) My function is the answer to this.

If I try to condense your library down to just contain the necessary elements for the GetLocalPath Function, I have about 680 lines of code, including some Private Types that pretty much only make it portable as a separate module. But realistically, If someone would want to use your solution, they'd have to use the whole library, because cherry-picking this one thing out of your library is way too much work. In most cases, this is just overkill because as I said, this often occurs as an isolated problem. My solution, while still not short at like 240 loc, can be copied and pasted into any module and should work just fine. If you need it somewhere else, you copy and paste that chunk of code, no interdependencies, nothing.

Maybe I'll split it up into more routines in the future, or maybe I'll just try to condense the function as a whole.

Moreover, I would like to use the cache to convert from local path to OneDrive path (as I already do in the repo, although clearly wrong as it is) and so the cache must sit outside of the 2 functions using the cache: GetLocalPath and GetWebPath. One more reason to split.

My function does cache the WebToLocDict which is used to convert all possible WebPaths in the future. It is computed on the first call to the function and should remain in memory until it is recompiled. Why can the caching only happen outside the function? I thought that's what static variables were for. Could you please explain what you mean by that?

This is excellent news. It does pass all my tests as well. Thank you very much for all your help! I could not have done this without you. I will surely mention your name and link to this issue at the top of the function signature.

This is very kind and much appreciated, thank you!

[guwidoe]

@cristianbuse

However, I want to be sure that I got what the issue was. I basically added a new section to the GetOneDriveProviders function to add a separate provider in case a Personal folder was synchronized as well. Can you please test the below?

I just tested your updated code, it still fails the same three tests. If you have an idea how I can help you debug (registry screenshots, breakpoints in the code etc.) please let me know. I'm happy to help!

[cristianbuse]

Thanks @guwidoe for the explanation!

They want something to copy and paste that should work. (That's what I want at least) My function is the answer to this.

I completely understand this. And I think you should definitely post back on Stack Overflow once you remove some of the duplication.

However, this repository has a few useful/indispensable functions (like IsFile or GetFolders) and my goal is to always have the user to get the whole library. Moreover, the current GetLocalPath from this repository also takes care of network UNC paths for mapped drives so that makes it even more coupled with the rest of the module.

Why can the caching only happen outside the function? I thought that's what static variables were for. Could you please explain what you mean by that?

I want 2 separate publicly exposed functions to access the same cache and so the cache cannot be defined in any one of them. It must either be module level or declared as Static inside a 3rd private function that is called by both the public functions. In the current form of the module there is a GetOneDriveInfo that does just that and is called from both GetOneDriveLocalPath and GetOneDriveWebPath.

I just tested your updated code, it still fails the same three tests. If you have an idea how I can help you debug (registry screenshots, breakpoints in the code etc.) please let me know. I'm happy to help!

Could you please check if the folderName = collFolders(folderID) line inside the FixPersonalProviders method is returning the correct value and if it does then what is the next line i = FindPersonalProvider(providers, cid, folderName) returning?

[guwidoe]

I want 2 separate publicly exposed functions to access the same cache

I see, this explains it of course!

Moreover, the current GetLocalPath from this repository also takes care of network UNC paths for mapped drives so that makes it even more coupled with the rest of the module.

Oh, I have never even considered this! That's cool! It's much less important for me because ThisWorkbook.FullName seems to already return a local path in this case, as per the testing I just did. I can definitely see some use cases for such a feature though.

ould you please check if the folderName = collFolders(folderID) line inside the FixPersonalProviders method is returning the correct value and if it does then what is the next line i = FindPersonalProvider(providers, cid, folderName) returning?

I tested the requested line as follows: EDIT: I added some more printing.

'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
                               , ByVal datPath As String _
                               , ByRef providers() As OneDriveProvider)
    Dim s As String: s = ReadBytes(iniPath)
    If LenB(s) = 0 Then Exit Sub
    '
    Dim lines() As String: lines = Split(s, vbNewLine)
    Dim lineText As Variant
    Dim i As Long
    Dim cid As String
    Dim relPath As String
    Dim folderID As String
    Dim folderName As String
    Dim collFolders As Collection

    Dim gwdDict As Object
    Set gwdDict = PersonalFoldersDict

    For Each lineText In lines
        i = InStr(1, lineText, "_")
        If i > 0 Then
            Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
            Case "BaseUri"
                cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            Case "Path"
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(datPath)
                End If
                If collFolders.count > 0 Then
                    folderName = collFolders(folderID)
                    If folderName <> gwdDict(folderID)(1) Then
                        Debug.Print "error"
                    End If
                    i = FindPersonalProvider(providers, cid, folderName)
                    Debug.Print i
                    If i > 0 Then
                        With providers(i)
                            .urlNamespace = .urlNamespace & "/" & relPath
                            .isSet = True
                            Debug.Print .urlNamespace, cid, folderName
                        End With
                    End If
                End If
            End Select
        End If
    Next lineText
End Sub

error doesn't get printed, so your FolderID <> FolderName correlation is the same as mine. This is the output:

 33 
https://d.docs.live.net/5cfc6adc55f2ae2b/Test/Test      5CFC6ADC55F2AE2B!106        Test
 32 
https://d.docs.live.net/5cfc6adc55f2ae2b/FirstLevel/SecondLevel       5CFC6ADC55F2AE2B!110        SecondLevel
 34 
https://d.docs.live.net/3dea8a9886f05935/Test/Test/Test 3DEA8A9886F05935!108        Test (1)
 30 
https://d.docs.live.net/3dea8a9886f05935/Test (1)/SecondLevel/Test (1)/FourthLevel  3DEA8A9886F05935!118        FourthLevel
 35 
https://d.docs.live.net/3dea8a9886f05935/Test (2)/SecondLevel/Test (1)              3DEA8A9886F05935!124        Test (1) (1)
 38 
https://d.docs.live.net/733ae81c3aefa499/Test/Test      733AE81C3AEFA499!106        Test (2)
 36 
https://d.docs.live.net/3dea8a9886f05935/Test (3)/SecondLevel/Test (1)/FourthLevel/Test (1)       3DEA8A9886F05935!134        Test (1) (2)
 37 
https://d.docs.live.net/3dea8a9886f05935/Test (4)/SecondLevel/Test (1)/FourthLevel/Test (1)       3DEA8A9886F05935!141        Test (1) (3)
 23 
https://d.docs.live.net/3dea8a9886f05935/Business1      3DEA8A9886F05935!144        Business1
 39 
https://d.docs.live.net/5cfc6adc55f2ae2b/Test (1)/Test  5CFC6ADC55F2AE2B!119        Test (3)
 0 

[cristianbuse]

@guwidoe

Cool. It seems the very last one is a 0 so that's the issue.

Could you replace this:

Debug.Print i

with this:

If i = 0 Then
    Debug.Print cid, folderName
    Stop
End If

and then check in the providers array (in the Locals window) if you can find a provider that: 1) has the .actualFolder equal with the folderName but the wrong cid OR 2) has the correct cid but the .actualFolder is differrent from the folderName OR 3) something else that I'm obviously missing

Thanks!

[guwidoe]

Hi @cristianbuse

Indeed I found a folder that has the .actualFolder equal with the folderName but the wrong cid

I think that is because depending on which of these two events happened last, there can be different cid's in the registry for this registry key:

1. Last re-logged into my personal OneDrive Account
2. Last synchronized a folder called "Personal" from someone else's personal OneDrive

Because of this confusion, I stopped using the registry for personal OneDrive.

[cristianbuse]

@guwidoe ,

Thanks! Indeed I need to stop using the registry for personal OneDrive. At least now I know that is the only issue.

[guwidoe]

I refactored my code down to this 200 line monstrosity:

Public Function GetLocalPath(ByVal Path As String, _
                    Optional ByVal rebuildCache As Boolean = False) _
                             As String
#If Mac Then
    GetLocalPath = Path: Exit Function
#End If
    Const HKCU = &H80000001
    Const computerName As String = "."
    Dim webRoot As String, vKey As Variant, i As Long

    Static WebToLocDict As Object
    If Not WebToLocDict Is Nothing And Not rebuildCache Then
        For Each vKey In WebToLocDict.Keys
            If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
                Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
                GetLocalPath = Replace(Path, "/", "\"): Exit Function
            End If
        Next vKey
        GetLocalPath = Path: Exit Function
    End If

    Dim objReg As Object
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
                            computerName & "\root\default:StdRegProv")
    Dim regPath As String: regPath = "Software\SyncEngines\Providers\OneDrive\"

    Dim LocToWebDict As Object
    Set LocToWebDict = CreateObject("Scripting.Dictionary")

    Dim cid As String, libType As String, locRoot As String
    Dim subKeys() As Variant, subKey As Variant

    'Initializing the dict with Business OneDrive MountPoints from the registry:
    objReg.EnumKey HKCU, regPath, subKeys
    For Each subKey In subKeys
        objReg.GetStringValue HKCU, regPath & subKey, "UrlNamespace", webRoot
        objReg.GetStringValue HKCU, regPath & subKey, "MountPoint", locRoot
        objReg.GetStringValue HKCU, regPath & subKey, "LibraryType", libType
        If libType <> "personal" Then LocToWebDict(locRoot) = webRoot
    Next subKey

    'Adding personal root folder to the translation dict
    objReg.GetStringValue HKCU, regPath & "Personal", "UrlNamespace", webRoot
    regPath = "Software\Microsoft\OneDrive\Accounts\"
    objReg.GetStringValue HKCU, regPath & "Personal", "UserFolder", locRoot
    objReg.GetStringValue HKCU, regPath & "Personal", "cid", cid
    If webRoot <> "" And locRoot <> "" And cid <> "" Then: _
        LocToWebDict(locRoot) = webRoot & "/" & cid

    Dim fileNumber As Long, lineText As String, lineParts() As String
    Dim bytes() As Byte, byteStr As String: byteStr = ""
    Dim pos As Long, str As String
    Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
    Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
    Dim parentID As String, folderID As String, folderName As String
    Dim lenFolderName As Long, folderIdPattern As String
    Dim odFolders As Object

    Dim settPath As String
    objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
    settPath = settPath & "\Microsoft\OneDrive\settings\"

    Dim PersGroupFoldersIniEx As Boolean
    PersGroupFoldersIniEx = (Dir(settPath & "Personal\GroupFolders.ini") <> "")

    Dim CidIniEx As Object: Set CidIniEx = CreateObject("Scripting.Dictionary")
    Dim CidDatEx As Object: Set CidDatEx = CreateObject("Scripting.Dictionary")
    For i = 0 To 9
        objReg.GetStringValue HKCU, regPath & "Business" & i, "cid", cid
        CidIniEx.Add Key:="Business" & i, _
            item:=(Dir(settPath & "Business" & i & "\" & cid & ".ini") <> "")
        CidDatEx.Add Key:="Business" & i, _
            item:=(Dir(settPath & "Business" & i & "\" & cid & ".dat") <> "")
    Next i

    'Refining the dict using .ini and .dat files in the OneDrive settings:
    Dim dirName As String: dirName = Dir(settPath, vbDirectory)
    Do Until dirName = ""
        objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
        If cid = "" Then GoTo NextFolder
        'Read dirName\cid.dat file
        fileNumber = FreeFile
        Open settPath & dirName & "\" & cid & ".dat" For Binary Access Read _
                                                                As #fileNumber
        On Error GoTo CloseFile
        ReDim bytes(0 To LOF(fileNumber) - 1)
        Get fileNumber, , bytes: byteStr = bytes
        Close #fileNumber: fileNumber = 0: On Error GoTo 0
        If dirName Like "Business#" Then
           If Not (CidIniEx(dirName) And CidDatEx(dirName)) Then GoTo NextFolder
           folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
        ElseIf dirName = "Personal" Then
            If Not PersGroupFoldersIniEx Then GoTo NextFolder
            folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
        End If
        Set odFolders = CreateObject("Scripting.Dictionary")
        pos = InStrB(1, byteStr, sig1)
        Do Until pos = 0
            If InStrB(pos, byteStr, sig2) - pos = 16 Then
                folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
                                                vbUnicode), vbNullChar, "")
                parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
                                                vbUnicode), vbNullChar, "")
                lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
                                vbNullChar) - (pos + 184)) / 2) * 2
                folderName = MidB(byteStr, pos + 184, lenFolderName)
                If folderID Like folderIdPattern Then
                    odFolders.Add Key:=folderID, _
                                  item:=Array(parentID, folderName)
                End If
            End If
            pos = InStrB(pos + 1, byteStr, sig1)
        Loop
        'Read relevant .ini files
        Select Case True
        Case dirName Like "Business#"
        'Max 9 Business OneDrive accounts can be signed in at a time.
            fileNumber = FreeFile
            Open settPath & dirName & "\" & cid & ".ini" For _
                Input Access Read As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                Select Case left$(lineText, InStr(lineText, " = ") - 1)
                Case "libraryScope" '-> No change to dict necessary
                Case "libraryFolder"
                    locRoot = Split(lineText, """")(1)
                    parentID = left(Split(lineText, " ")(4), 32)
                    For Each vKey In LocToWebDict.Keys
                        If vKey = locRoot Then
                            str = ""
                            Do Until Not odFolders.Exists(parentID)
                                str = odFolders(parentID)(1) & "/" & str
                                parentID = odFolders(parentID)(0)
                            Loop
                            LocToWebDict(vKey) = LocToWebDict(vKey) & str
                            Exit For
                        End If
                    Next vKey
                Case "AddedScope"
                    lineParts = Split(lineText, """")
                    For Each vKey In LocToWebDict.Keys
                        webRoot = LocToWebDict(vKey)
                        If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
                        1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
                        odFolders(left(Split(lineText, " ")(3), 32))(1) Then
                            LocToWebDict(vKey) = LocToWebDict(vKey) & _
                                                 lineParts(5)
                            Exit For
                        End If
                    Next vKey
                Case Else
                    Exit Do
                End Select
            Loop
            Close #fileNumber: fileNumber = 0: On Error GoTo 0
        Case dirName = "Personal"
        'Only one Personal OneDrive account can be signed in at a time.
            objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
            webRoot = Replace(LocToWebDict(locRoot), "/" & cid, "")
            cid = ""
            fileNumber = FreeFile
            Open settPath & dirName & "\GroupFolders.ini" For _
                Input Access Read As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                If InStr(lineText, "BaseUri = https://") And cid = "" Then
                    cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
                    folderID = left(lineText, InStr(lineText, "_") - 1)
                ElseIf cid <> "" Then
                    LocToWebDict.Add _
                        Key:=locRoot & "\" & odFolders(folderID)(1), _
                        item:=webRoot & "/" & cid & "/" & _
                              Replace(lineText, folderID & "_Path = ", "")
                    cid = "": folderID = ""
                End If
            Loop
            Close #fileNumber: fileNumber = 0: On Error GoTo 0
        Case Else
        End Select
NextFolder:
        byteStr = "": Set odFolders = Nothing
        dirName = Dir
    Loop

    Set WebToLocDict = Nothing
    Set WebToLocDict = CreateObject("Scripting.Dictionary")
    For Each vKey In LocToWebDict.Keys
        locRoot = vKey
        webRoot = LocToWebDict(vKey)
       If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
       If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
        WebToLocDict.Add Key:=webRoot, item:=locRoot
    Next vKey

    GetLocalPath = GetLocalPath(Path, False): Exit Function
CloseFile:
    If fileNumber <> 0 Then: Close #fileNumber: err.Raise err
End Function

Could you please confirm that it still works? I restructured it quite a bit, now there isn't much duplicated code remaining. Also, I added some safety checks. Now it checks if the files being read actually exist before attempting to read them, otherwise this can lead to errors, especially with the GroupFolders.ini file which just doesn't exist if you don't have other synced folders in your personal OneDrive. Also, the performance seems to have improved... I don't even know why, but I'll take it 🤷‍♂️ The first run now takes around 1.5 seconds for my setup, which is about the same time your current solution takes.

I do think performance wise it could certainly be improved a bit, but I think it's good enough considering my OneDrive contains quite a lot of stuff.

[cristianbuse]

@guwidoe

It still passes all my tests. On my computer, it only takes 0.35 seconds to run your function so this is clearly related to the size of the DAT files. However any subsequent run only takes 0.027 seconds so the cache works well.

[guwidoe]

Interestingly, reading the .dat files is surprisingly fast. I now profiled my function, of the total runtime of 2,6 seconds, reading the .dat files is only like 1/5th:

Read Business1.dat in 0,484375 seconds (151MB)
Read Business2.dat in 0,0078125 seconds (74KB)
Read Personal.dat in 0,0078125 seconds (2,8MB)

I think what takes most of the time are the various registry reads. In fact, I just tested a different method for reading the registry and it seems to perform so much better:

Sub test()
    Const HKCU = &H80000001
    Const computerName As String = "."

    Dim numReads As Long
    numReads = 100

    Dim objReg As Object
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
                            computerName & "\root\default:StdRegProv")
    Dim regPath As String
    regPath = "Software\Microsoft\OneDrive\Accounts\Personal\"
    Dim regKey As String
    regKey = "UserFolder"
    Dim locRoot As String, i As Long, t As Single
    t = Timer()
    For i = 1 To numReads
        objReg.GetStringValue HKCU, regPath, regKey, locRoot
        If i = 1 Then Debug.Print locRoot
        locRoot = ""
    Next i
    Debug.Print numReads & " registry reads with current technique: " & Timer() - t & " seconds"

    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    t = Timer()
    For i = 1 To numReads
        locRoot = objShell.RegRead("HKCU\" & regPath & regKey)
        If i = 1 Then Debug.Print locRoot
        locRoot = ""
    Next i
    Debug.Print numReads & " registry reads with Shell technique: " & Timer() - t & " seconds"
End Sub

This produces the following output for me:

C:\Users\Witt-DörringGuidoABC\OneDrive
100 registry reads with current technique: 0,4296875 seconds
C:\Users\Witt-DörringGuidoABC\OneDrive
100 registry reads with Shell technique: 0,0078125 seconds

Is it time to change the way we read the registry or is there a different reason to go with our current technique?

[guwidoe]

Hi @cristianbuse

I looked into it a little bit and came to the following conclusions: The Shell technique doesn't offer a way to enumerate a key, so we need the slow method for this step. Also, the Shell method doesn't fail silently but throws an error if the read isn't successful, for instance, if the key doesn't exist.

As I'm relying on both, the EnumKey method and silent failure of the method we are using I can't replace all usage of it. But in my function, most of the reads happen to read all the business MountPoints, and for this purpose, using the Shell technique should work just fine. In fact, by implementing it that way I managed to get the total runtime of my function down by a factor of 3.

I also looked into what it would take to avoid reading the registry completely, but I think that would make it unnecessarily complicated because a lot more files from the settings directory would need to be read, namely all the ClientPolicy.ini files to get the full UrlNamespace for all the mount points.

This is my updated function that runs at least 3 times faster:

Public Function GetLocalPath(ByVal Path As String, _
                    Optional ByVal rebuildCache As Boolean = False) _
                             As String
#If Mac Then
    GetLocalPath = Path: Exit Function
#End If
    Const HKCU = &H80000001: Const sHKCU  As String = "HKCU\"
    Const computerName As String = "."
    Dim webRoot As String, vKey As Variant, i As Long

    Static WebToLocDict As Object
    If Not WebToLocDict Is Nothing And Not rebuildCache Then
        For Each vKey In WebToLocDict.Keys
            If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
                Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
                GetLocalPath = Replace(Path, "/", "\"): Exit Function
            End If
        Next vKey
        GetLocalPath = Path: Exit Function
    End If

    Dim objReg As Object
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
                            computerName & "\root\default:StdRegProv")
    Dim oShell As Object: Set oShell = CreateObject("WScript.Shell")
    Dim regPath As String: regPath = "Software\SyncEngines\Providers\OneDrive\"

    Dim LocToWebDict As Object
    Set LocToWebDict = CreateObject("Scripting.Dictionary")

    Dim cid As String, libType As String, locRoot As String
    Dim subKeys() As Variant, subKey As Variant

    'Initializing the dict with Business OneDrive MountPoints from the registry:
    objReg.EnumKey HKCU, regPath, subKeys
    For Each subKey In subKeys
        libType = oShell.RegRead(sHKCU & regPath & subKey & "\LibraryType")
        If libType <> "personal" Then
            webRoot = oShell.RegRead(sHKCU & regPath & subKey & "\UrlNamespace")
            locRoot = oShell.RegRead(sHKCU & regPath & subKey & "\MountPoint")
            LocToWebDict(locRoot) = webRoot
        End If
    Next subKey

    'Adding personal root folder to the translation dict
    objReg.GetStringValue HKCU, regPath & "Personal", "UrlNamespace", webRoot
    regPath = "Software\Microsoft\OneDrive\Accounts\"
    objReg.GetStringValue HKCU, regPath & "Personal", "UserFolder", locRoot
    objReg.GetStringValue HKCU, regPath & "Personal", "cid", cid
    If webRoot <> "" And locRoot <> "" And cid <> "" Then: _
        LocToWebDict(locRoot) = webRoot & "/" & cid

    Dim fileNumber As Long, lineText As String, lineParts() As String
    Dim bytes() As Byte, byteStr As String: byteStr = ""
    Dim pos As Long, str As String
    Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
    Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
    Dim parentID As String, folderID As String, folderName As String
    Dim lenFolderName As Long, folderIdPattern As String, odFolders As Object

    Dim settPath As String
    objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
    settPath = settPath & "\Microsoft\OneDrive\settings\"

    Dim PersGroupFoldersIniEx As Boolean
    PersGroupFoldersIniEx = (Dir(settPath & "Personal\GroupFolders.ini") <> "")

    Dim CidIniEx As Object: Set CidIniEx = CreateObject("Scripting.Dictionary")
    Dim CidDatEx As Object: Set CidDatEx = CreateObject("Scripting.Dictionary")
    For i = 0 To 9
        objReg.GetStringValue HKCU, regPath & "Business" & i, "cid", cid
        CidIniEx.Add Key:="Business" & i, _
            item:=(Dir(settPath & "Business" & i & "\" & cid & ".ini") <> "")
        CidDatEx.Add Key:="Business" & i, _
            item:=(Dir(settPath & "Business" & i & "\" & cid & ".dat") <> "")
    Next i

    'Refining the dict using .ini and .dat files in the OneDrive settings:
    Dim dirName As String: dirName = Dir(settPath, vbDirectory)
    Do Until dirName = ""
        objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
        If cid = "" Then GoTo NextFolder
        'Read dirName\cid.dat file
        fileNumber = FreeFile
        Open settPath & dirName & "\" & cid & ".dat" For Binary Access Read _
                                                                As #fileNumber
        On Error GoTo CloseFile
        ReDim bytes(0 To LOF(fileNumber) - 1)
        Get fileNumber, , bytes: byteStr = bytes
        Close #fileNumber: fileNumber = 0: On Error GoTo 0
        If dirName Like "Business#" Then
           If Not (CidIniEx(dirName) And CidDatEx(dirName)) Then GoTo NextFolder
           folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
        ElseIf dirName = "Personal" Then
            If Not PersGroupFoldersIniEx Then GoTo NextFolder
            folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
        End If
        Set odFolders = CreateObject("Scripting.Dictionary")
        pos = InStrB(1, byteStr, sig1)
        Do Until pos = 0
            If InStrB(pos, byteStr, sig2) - pos = 16 Then
                folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
                                                vbUnicode), vbNullChar, "")
                parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
                                                vbUnicode), vbNullChar, "")
                lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
                                vbNullChar) - (pos + 184)) / 2) * 2
                folderName = MidB(byteStr, pos + 184, lenFolderName)
                If folderID Like folderIdPattern Then
                    odFolders.Add Key:=folderID, _
                                  item:=Array(parentID, folderName)
                End If
            End If
            pos = InStrB(pos + 1, byteStr, sig1)
        Loop
        'Read relevant .ini files
        Select Case True
        Case dirName Like "Business#"
        'Max 9 Business OneDrive accounts can be signed in at a time.
            fileNumber = FreeFile
            Open settPath & dirName & "\" & cid & ".ini" For Input Access Read _
                                                                  As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                Select Case left$(lineText, InStr(lineText, " = ") - 1)
                Case "libraryScope" '-> No change to dict necessary
                Case "libraryFolder"
                    locRoot = Split(lineText, """")(1)
                    parentID = left(Split(lineText, " ")(4), 32)
                    For Each vKey In LocToWebDict.Keys
                        If vKey = locRoot Then
                            str = ""
                            Do Until Not odFolders.Exists(parentID)
                                str = odFolders(parentID)(1) & "/" & str
                                parentID = odFolders(parentID)(0)
                            Loop
                            LocToWebDict(vKey) = LocToWebDict(vKey) & str
                            Exit For
                        End If
                    Next vKey
                Case "AddedScope"
                    lineParts = Split(lineText, """")
                    For Each vKey In LocToWebDict.Keys
                        webRoot = LocToWebDict(vKey)
                        If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
                        1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
                        odFolders(left(Split(lineText, " ")(3), 32))(1) Then
                            LocToWebDict(vKey) = LocToWebDict(vKey) & _
                                                 lineParts(5)
                            Exit For
                        End If
                    Next vKey
                Case Else
                    Exit Do
                End Select
            Loop
            Close #fileNumber: fileNumber = 0: On Error GoTo 0
        Case dirName = "Personal"
        'Only one Personal OneDrive account can be signed in at a time.
            objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
            webRoot = Replace(LocToWebDict(locRoot), "/" & cid, "")
            cid = ""
            fileNumber = FreeFile
            Open settPath & dirName & "\GroupFolders.ini" For _
                Input Access Read As #fileNumber
            On Error GoTo CloseFile
            Do While Not EOF(fileNumber)
                Line Input #fileNumber, lineText
                If InStr(lineText, "BaseUri = https://") And cid = "" Then
                    cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
                    folderID = left(lineText, InStr(lineText, "_") - 1)
                ElseIf cid <> "" Then
                    LocToWebDict.Add _
                        Key:=locRoot & "\" & odFolders(folderID)(1), _
                        item:=webRoot & "/" & cid & "/" & _
                              Replace(lineText, folderID & "_Path = ", "")
                    cid = "": folderID = ""
                End If
            Loop
            Close #fileNumber: fileNumber = 0: On Error GoTo 0
        Case Else
        End Select
NextFolder:
        byteStr = "": Set odFolders = Nothing
        dirName = Dir
    Loop

    Set WebToLocDict = Nothing
    Set WebToLocDict = CreateObject("Scripting.Dictionary")
    For Each vKey In LocToWebDict.Keys
        locRoot = vKey: webRoot = LocToWebDict(vKey)
       If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
       If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
        WebToLocDict.Add Key:=webRoot, item:=locRoot
    Next vKey

    GetLocalPath = GetLocalPath(Path, False): Exit Function
CloseFile:
    If fileNumber <> 0 Then: Close #fileNumber: err.Raise err
End Function

32/32 Tests passed in 0,664063 seconds.

[cristianbuse]

Hi @guwidoe ,

Funny that you mentioned skipping registry entirely. I was working on exactly that this morning.

I've seen in many comments on Stack Overflow that some people cannot read registry at all (due to company policy). So, skipping registry should help those people. Reading the ClientPolicy files is super fast so overall the solution is actually faster.

Can you please test the below? Thanks!

Option Explicit

Private Type OneDriveMap
    localPath As String
    webPath As String
End Type

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Dim arrMap() As OneDriveMap: PopulateMaps arrMap, rebuildCache:=False
    Dim i As Long
    Dim webPath
    Dim tempPath As String
    Dim rPart As String
    '
    For i = LBound(arrMap) To UBound(arrMap)
        webPath = arrMap(i).webPath
        tempPath = Left$(odWebPath, Len(webPath))
        If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
    Next i
    If i > UBound(arrMap) Then Exit Function
    '
    rPart = Replace(odWebPath, webPath, vbNullString, , , vbTextCompare)
    GetOneDriveLocalPath = BuildPath(arrMap(i).localPath, rPart)
End Function

Private Sub PopulateMaps(ByRef arrMap() As OneDriveMap _
                       , ByVal rebuildCache As Boolean)
    Static arrLocalMap() As OneDriveMap
    Static isSet As Boolean
    '
    If rebuildCache Then isSet = False
    If isSet Then
        arrMap = arrLocalMap
        Exit Sub
    End If
    '
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim collLocalPaths As New Collection
    Dim collWebPaths As New Collection
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            AddBusinessPaths folderPath, collLocalPaths, collWebPaths
        ElseIf folderName = "Personal" Then
            AddPersonalPaths folderPath, collLocalPaths, collWebPaths
        End If
    Next folderPath
    If collLocalPaths.Count = 0 Then
        ReDim arrLocalMap(0 To 0)
    Else
        ReDim arrLocalMap(0 To collLocalPaths.Count - 1)
        Dim i As Long
        Dim v As Variant
        '
        i = 0
        For Each v In collLocalPaths
            arrLocalMap(i).localPath = v
            i = i + 1
        Next v
        i = 0
        For Each v In collWebPaths
            arrLocalMap(i).webPath = v
            i = i + 1
        Next v
    End If
    arrMap = arrLocalMap
    isSet = True
End Sub

Private Sub AddBusinessPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
    If LenB(iniName) = 0 Then Exit Sub
    '
    Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
    Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
    Dim bytes() As Byte:   ReadBytes iniPath, bytes
    Dim lineText As Variant
    Dim parts() As String
    Dim tempMount As String
    Dim tempURL As String
    Dim tempID As String
    Dim tempFolder As String
    Dim prevID As String
    Dim collFolders As Collection
    Dim collParents As Collection
    Dim collPending As New Collection
    '
    For Each lineText In Split(bytes, vbNewLine)
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            parts = Split(lineText, """")
            tempMount = parts(9)
            If LenB(tempMount) = 0 Then tempID = Split(parts(0), " ")(2)
            If parts(3) = "ODB" Then
                tempURL = GetUrlNamespace(folderPath)
            Else
                parts = Split(parts(8), " ")
                tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1))
            End If
            If LenB(tempMount) = 0 Then
                collPending.Add tempURL, tempID
            Else
                collLocalPaths.Add tempMount
                collWebPaths.Add tempURL
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath, collParents)
            parts = Split(lineText, """")
            tempMount = parts(1)
            parts = Split(parts(0), " ")
            tempURL = collPending(parts(3))
            tempID = Split(parts(4), "+")(0)
            tempFolder = vbNullString
            On Error Resume Next
            Do
                tempFolder = collFolders(tempID) & "/" & tempFolder
                prevID = tempID
                tempID = collParents(tempID)
            Loop Until Err.Number <> 0 Or prevID = tempID
            On Error GoTo 0
            If LenB(tempFolder) > 0 Then
                collLocalPaths.Add tempMount
                collWebPaths.Add tempURL & tempFolder
            End If
        Case "AddedScope"
            If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath)
            parts = Split(lineText, """")
            collLocalPaths.Add collLocalPaths(1) & "\" & collFolders(Split(parts(0), " ")(3))
            tempURL = parts(5)
            parts = Split(parts(4), " ")
            tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1) & parts(4)) & tempURL
            collWebPaths.Add tempURL
        Case Else
            Exit For
        End Select
    Next lineText
End Sub

Private Function GetUrlNamespace(ByVal folderPath As String _
                               , Optional ByVal clientSignature As String) As String
    Const nTag As String = "DavUrlNamespace"
    Dim bytes() As Byte
    Dim lineText As Variant
    '
    ReadBytes BuildPath(folderPath, "ClientPolicy" & clientSignature & ".ini"), bytes
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, Len(nTag)) = nTag Then
            GetUrlNamespace = Mid$(lineText, InStr(Len(nTag) + 2, lineText, "https://"))
            Exit Function
        End If
    Next lineText
End Function

Private Sub AddPersonalPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
    Dim iniPath As String
    '
    Do
        iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
        If IsFile(iniPath) Then Exit Do
        datName = Dir
    Loop Until LenB(datName) = 0
    '
    Dim tempMount As String
    Dim tempURL As String: tempURL = GetUrlNamespace(folderPath) & "/"
    Dim bytes() As Byte: ReadBytes iniPath, bytes
    Dim lineText As Variant
    '
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, InStr(1, lineText, " ") - 1) = "library" Then
            tempMount = Split(lineText, """")(3) & "\"
            Exit For
        End If
    Next lineText
    collLocalPaths.Add tempMount
    collWebPaths.Add tempURL & Replace(datName, ".dat", vbNullString) & "/"
    '
    Dim groupPath As String: groupPath = BuildPath(folderPath, "GroupFolders.ini")
    Dim cid As String
    Dim i As Long
    Dim relPath As String
    Dim folderID As String
    Dim collFolders As Collection
    '
    If Not IsFile(groupPath) Then Exit Sub
    ReadBytes groupPath, bytes
    '
    For Each lineText In Split(bytes, vbNewLine)
        If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
            cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            i = InStr(1, cid, "!")
            If i > 0 Then cid = Left$(cid, i - 1)
        Else
            i = InStr(1, lineText, "_Path", vbTextCompare)
            If i > 0 Then
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
                End If
                If collFolders.Count > 0 Then
                    collLocalPaths.Add tempMount & collFolders(folderID)
                    collWebPaths.Add tempURL & cid & "/" & relPath
                End If
            End If
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim b() As Byte:  ReadBytes filePath, b
    Dim s As String:  s = b
    Dim size As Long: size = LenB(s)
    If size = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                '
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    collFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
    Dim fileNumber As Long: fileNumber = FreeFile()
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim result(0 To LOF(fileNumber) - 1)
    Get fileNumber, , result
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Sub

[guwidoe]

Hi @cristianbuse

I've seen in many comments on Stack Overflow that some people cannot read registry at all. So, skipping registry should help those people. Reading the ClientPolicy files is super fast so overall the solution is actually faster.

I have seen one such comment too but decided it was more important to keep my solution as short as possible since I am trying to shove everything into a single procedure. Now that you are going for it maybe I'll write such a solution too.

Runtime wise your new solution is now very similar to my last solution, maybe a smidge faster. However, there are still two tests that fail, which my solution passes:

FAILED Test Business2 SharePoint Library added as Link (3rd level mount)
URL path: https://tuwienacat.sharepoint.com/sites/TestLib2/Freigegebene Dokumente/Level2/Level3/test.xlsm
Func ret: C:\Users\Witt-DörringGuidoABC\OneDrive - ABC\Level3\test.xlsm
act path: C:\Users\Witt-DörringGuidoABC\OneDrive - TU Wien\Level3\test.xlsm

FAILED Business Account Personal Folder, Library as Link, linked folder same name as other folder in personal OneDrive
URL path: https://tuwienacat.sharepoint.com/sites/TestLib2/Freigegebene Dokumente/Test/Test/Test/test.xlsm
Func ret: C:\Users\Witt-DörringGuidoABC\OneDrive - ABC\Test - TestLinkLib\Test\test.xlsm
act path: C:\Users\Witt-DörringGuidoABC\OneDrive - TU Wien\Test - TestLinkLib\Test\test.xlsm

Both of these cases are related to adding a SharePoint library as a link to your personal business OneDrive, and for some reason, your solution substitutes the Business1 local path instead of the Business2 one. I think this should be easy to fix.

I have one more question regarding your implementation of GetODFolders: Why are you using this loop:

    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, Check)
        Do While i > stepSize And i < size - 168
        '....
        Loop
    Next v

What is stepSize for?

[cristianbuse]

Hi @guwidoe ,

Thanks!

Yeah, forgot a small detail. Fixed now and it should pass all tests:

Option Explicit

Private Type OneDriveMap
    localPath As String
    webPath As String
End Type

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Dim arrMap() As OneDriveMap: PopulateMaps arrMap, rebuildCache:=False
    Dim i As Long
    Dim webPath
    Dim tempPath As String
    Dim rPart As String
    '
    For i = LBound(arrMap) To UBound(arrMap)
        webPath = arrMap(i).webPath
        tempPath = Left$(odWebPath, Len(webPath))
        If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
    Next i
    If i > UBound(arrMap) Then Exit Function
    '
    rPart = Replace(odWebPath, webPath, vbNullString, , , vbTextCompare)
    GetOneDriveLocalPath = BuildPath(arrMap(i).localPath, rPart)
End Function

Private Sub PopulateMaps(ByRef arrMap() As OneDriveMap _
                       , ByVal rebuildCache As Boolean)
    Static arrLocalMap() As OneDriveMap
    Static isSet As Boolean
    '
    If rebuildCache Then isSet = False
    If isSet Then
        arrMap = arrLocalMap
        Exit Sub
    End If
    '
    Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
    Dim settingsPath As String
    Dim folderPath As Variant
    Dim folderName As String
    Dim collLocalPaths As New Collection
    Dim collWebPaths As New Collection
    '
    settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
    For Each folderPath In GetFolders(settingsPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
        If folderName Like "Business*" Then
            AddBusinessPaths folderPath, collLocalPaths, collWebPaths
        ElseIf folderName = "Personal" Then
            AddPersonalPaths folderPath, collLocalPaths, collWebPaths
        End If
    Next folderPath
    If collLocalPaths.Count = 0 Then
        ReDim arrLocalMap(0 To 0)
    Else
        ReDim arrLocalMap(0 To collLocalPaths.Count - 1)
        Dim i As Long
        Dim v As Variant
        '
        i = 0
        For Each v In collLocalPaths
            arrLocalMap(i).localPath = v
            i = i + 1
        Next v
        i = 0
        For Each v In collWebPaths
            arrLocalMap(i).webPath = v
            i = i + 1
        Next v
    End If
    arrMap = arrLocalMap
    isSet = True
End Sub

Private Sub AddBusinessPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
    If LenB(iniName) = 0 Then Exit Sub
    '
    Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
    Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
    Dim bytes() As Byte:   ReadBytes iniPath, bytes
    Dim lineText As Variant
    Dim mainIndex As Long
    Dim parts() As String
    Dim tempMount As String
    Dim tempURL As String
    Dim tempID As String
    Dim tempFolder As String
    Dim prevID As String
    Dim collFolders As Collection
    Dim collParents As Collection
    Dim collPending As New Collection
    '
    For Each lineText In Split(bytes, vbNewLine)
        Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
        Case "libraryScope"
            parts = Split(lineText, """")
            tempMount = parts(9)
            If LenB(tempMount) = 0 Then tempID = Split(parts(0), " ")(2)
            If parts(3) = "ODB" Then
                tempURL = GetUrlNamespace(folderPath)
                mainIndex = collLocalPaths.Count + 1
            Else
                parts = Split(parts(8), " ")
                tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1))
            End If
            If LenB(tempMount) = 0 Then
                collPending.Add tempURL, tempID
            Else
                collLocalPaths.Add tempMount
                collWebPaths.Add tempURL
            End If
        Case "libraryFolder"
            If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath, collParents)
            parts = Split(lineText, """")
            tempMount = parts(1)
            parts = Split(parts(0), " ")
            tempURL = collPending(parts(3))
            tempID = Split(parts(4), "+")(0)
            tempFolder = vbNullString
            On Error Resume Next
            Do
                tempFolder = collFolders(tempID) & "/" & tempFolder
                prevID = tempID
                tempID = collParents(tempID)
            Loop Until Err.Number <> 0 Or prevID = tempID
            On Error GoTo 0
            If LenB(tempFolder) > 0 Then
                collLocalPaths.Add tempMount
                collWebPaths.Add tempURL & tempFolder
            End If
        Case "AddedScope"
            If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath)
            parts = Split(lineText, """")
            collLocalPaths.Add collLocalPaths(mainIndex) & "\" & collFolders(Split(parts(0), " ")(3))
            tempURL = parts(5)
            parts = Split(parts(4), " ")
            tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1) & parts(4)) & tempURL
            collWebPaths.Add tempURL
        Case Else
            Exit For
        End Select
    Next lineText
End Sub

Private Function GetUrlNamespace(ByVal folderPath As String _
                               , Optional ByVal clientSignature As String) As String
    Const nTag As String = "DavUrlNamespace"
    Dim bytes() As Byte
    Dim lineText As Variant
    '
    ReadBytes BuildPath(folderPath, "ClientPolicy" & clientSignature & ".ini"), bytes
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, Len(nTag)) = nTag Then
            GetUrlNamespace = Mid$(lineText, InStr(Len(nTag) + 2, lineText, "https://"))
            Exit Function
        End If
    Next lineText
End Function

Private Sub AddPersonalPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
    Dim iniPath As String
    '
    Do
        iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
        If IsFile(iniPath) Then Exit Do
        datName = Dir
    Loop Until LenB(datName) = 0
    '
    Dim tempMount As String
    Dim tempURL As String: tempURL = GetUrlNamespace(folderPath) & "/"
    Dim bytes() As Byte: ReadBytes iniPath, bytes
    Dim lineText As Variant
    '
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, InStr(1, lineText, " ") - 1) = "library" Then
            tempMount = Split(lineText, """")(3) & "\"
            Exit For
        End If
    Next lineText
    collLocalPaths.Add tempMount
    collWebPaths.Add tempURL & Replace(datName, ".dat", vbNullString) & "/"
    '
    Dim groupPath As String: groupPath = BuildPath(folderPath, "GroupFolders.ini")
    Dim cid As String
    Dim i As Long
    Dim relPath As String
    Dim folderID As String
    Dim collFolders As Collection
    '
    If Not IsFile(groupPath) Then Exit Sub
    ReadBytes groupPath, bytes
    '
    For Each lineText In Split(bytes, vbNewLine)
        If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
            cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            i = InStr(1, cid, "!")
            If i > 0 Then cid = Left$(cid, i - 1)
        Else
            i = InStr(1, lineText, "_Path", vbTextCompare)
            If i > 0 Then
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If collFolders Is Nothing Then
                    Set collFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
                End If
                If collFolders.Count > 0 Then
                    collLocalPaths.Add tempMount & collFolders(folderID)
                    collWebPaths.Add tempURL & cid & "/" & relPath
                End If
            End If
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim b() As Byte:  ReadBytes filePath, b
    Dim s As String:  s = b
    Dim size As Long: size = LenB(s)
    If size = 0 Then Exit Function
    '
    Dim hFolder As String
    Dim hCheck As String
    Dim i As Long
    Dim v As Variant
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim collFolders As New Collection
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    '
    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
    If outParents Is Nothing Then Set outParents = New Collection
    '
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 39
                bytes = InStrB(i, s, vbNullByte) - i
                If bytes < 0 Then bytes = 0
                If bytes > 39 Then bytes = 39
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                '
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                '
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    collFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If collFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = collFolders
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
    Dim fileNumber As Long: fileNumber = FreeFile()
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim result(0 To LOF(fileNumber) - 1)
    Get fileNumber, , result
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Sub

What is stepSize for?

Depending on the OneDrive version you can have the offsets in 8 bytes rather than 16 (for the dat file). So, I try 16 first and if it fails then I try 8. Basically for compatibility.

It seems we are getting closer to our goals. :blush: I am still planning to rewrite and make the code smaller but just wanted to be sure it works first.

[guwidoe]

Success! This version passes all my tests!

It seems we are getting closer to our goals. 😊 I am still planning to rewrite and make the code smaller but just wanted to be sure it works first.

Yes! I'm very glad, what a journey this was! I had a great time working on this with you! This was a good example of how important proper testing is in software development. That being said, I don't even consider my tests rigorous in any way, I wouldn't be surprised if there were other edge cases we have overlooked still. One such case where my solution might fail may be synchronizing a personal folder with the same name as a business folders FolderID I think your solution should be resilient to such attacks since you don't use the registry anymore.

If you want, I'd be very glad if you could let me know if you come across different interesting vba challenges in the future, I'm always looking for ways to improve my knowledge and I think this is a very good way to learn. I have looked at some of your posts on CodeReview and I'm very impressed by your code, I think it's some of the best vba code out there. What are the resources you use to improve? If you would be ok with this I'd send you my contact details via email.

[cristianbuse]

@guwidoe

Yes! I'm very glad, what a journey this was! I had a great time working on this with you!

Likewise, was a pleasure for me too! You were very thorough in your testing while I was being lazy.

I wouldn't be surprised if there were other edge cases we have overlooked still.

I am convinced. However, if we post a smaller footprint response on all of the relevant forum questions then we might get feedback when stuff breaks from other users. In other words, get indirect help with testing and coverage.

If you want, I'd be very glad if you could let me know if you come across different interesting vba challenges in the future

I was actually thinking to ask you if you'd like to collaborate on other VBA projects. I'm glad you're thinking the same. VBA is lacking a lot of functionality and there are plenty of gaps that we could fill in order to help others as well. I will think of some interesting mini projects and I will contact you. Or maybe you have something in mind and I will be glad to join in. We can then decide how we want to approach it and where (e.g. a repo on your account, a repo on my account or a joint 'organization' - for me it does not matter too much as my only goal is to help other people).

I'm always looking for ways to improve my knowledge and I think this is a very good way to learn

I know of only one 'good' way to learn and that is to solve problems i.e. learn by doing. I'm with you on this one.

I have looked at some of your posts on CodeReview and I'm very impressed by your code, I think it's some of the best vba code out there

Thank you very much! You are very kind.

What are the resources you use to improve?

I focus on specific problems and I am stubborn enough not to give up. I follow up in the smallest details and read relevant articles and books that help me get closer to solving the problem. Resources are always dependent on the problem at hand and so they are much easier to find. For example I spent 4 weeks on trying to find a faster alternative to CopyMemory and tried so many different things that eventually I came with something completely new as found here but that was only made possible by being stubborn. Learned quite a lot in the process.

If you would be ok with this I'd send you my contact details via email.

My email address should be public but here it is anyway: cristian.buse@yahoo.com Feel free to email me anytime

---

I will be rewriting the above code so that I get a smaller footprint. Will post it here when I'm done.

Best Regards, Cristian

[cristianbuse]

Hi @guwidoe ,

I've refactored my code. I don't think I can make it smaller without damaging readability. Can you please test it one last time? If it works, I will finally update the repository.

Option Explicit

'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
    If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
    '
    Dim collLocalPaths As Collection
    Dim collWebPaths As Collection
    Dim webPath As Variant
    Dim tempPath As String
    Dim rPart As String
    '
    PopulatePaths collLocalPaths, collWebPaths, rebuildCache:=False
    For Each webPath In collWebPaths
        tempPath = Left$(odWebPath, Len(webPath))
        If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
    Next webPath
    If IsEmpty(webPath) Then Exit Function
    '
    rPart = Replace(odWebPath, webPath, vbNullString, Compare:=vbTextCompare)
    GetOneDriveLocalPath = BuildPath(collLocalPaths(webPath), rPart)
End Function
Private Sub PopulatePaths(ByRef collLocal As Collection _
                        , ByRef collWeb As Collection _
                        , ByVal rebuildCache As Boolean)
    Static collLocalPaths As Collection
    Static collWebPaths As Collection
    Dim folderPath As Variant
    Dim folderName As String
    Dim appPath As String
    Dim redo As Boolean: redo = rebuildCache Or collLocalPaths Is Nothing
    '
    If redo Then
        Set collLocalPaths = New Collection
        Set collWebPaths = New Collection
    End If
    Set collLocal = collLocalPaths
    Set collWeb = collWebPaths
    If Not redo Then Exit Sub
    '
    appPath = BuildPath(Environ$("LOCALAPPDATA"), "Microsoft\OneDrive\settings\")
    For Each folderPath In GetFolders(appPath)
        folderName = Right$(folderPath, Len(folderPath) - Len(appPath))
        If folderName Like "Business*" Then
            AddBusinessPaths folderPath, collLocalPaths, collWebPaths
        ElseIf folderName = "Personal" Then
            AddPersonalPaths folderPath, collLocalPaths, collWebPaths
        End If
    Next folderPath
End Sub
Private Sub AddBusinessPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Const businessIniMask As String = "????????-????-????-????-????????????.ini"
    Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
    If LenB(iniName) = 0 Then Exit Sub
    '
    Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
    Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
    Dim bytes() As Byte:   ReadBytes iniPath, bytes
    Dim lineText As Variant
    Dim temp() As String
    Dim tempMount As String
    Dim mainMount As String
    Dim tempURL As String
    Dim cFolders As Collection
    Dim cParents As Collection
    Dim cPending As New Collection
    Dim canAdd As Boolean
    '
    For Each lineText In Split(bytes, vbNewLine)
        Dim parts() As String: parts = Split(lineText, """")
        Select Case Left$(lineText, InStr(1, lineText, " "))
        Case "libraryScope "
            tempMount = parts(9)
            canAdd = (LenB(tempMount) > 0)
            If parts(3) = "ODB" Then
                mainMount = tempMount
                tempURL = GetUrlNamespace(folderPath)
            Else
                temp = Split(parts(8), " ")
                tempURL = GetUrlNamespace(folderPath, "_" & temp(3) & temp(1))
            End If
            If Not canAdd Then cPending.Add tempURL, Split(parts(0), " ")(2)
        Case "libraryFolder "
            If cFolders Is Nothing Then
                Set cFolders = GetODFolders(datPath, cParents)
            End If
            tempMount = parts(1)
            temp = Split(parts(0), " ")
            tempURL = cPending(temp(3))
            Dim tempID As String:     tempID = Split(temp(4), "+")(0)
            Dim tempFolder As String: tempFolder = vbNullString
            On Error Resume Next
            Do
                tempFolder = cFolders(tempID) & "/" & tempFolder
                tempID = cParents(tempID)
            Loop Until Err.Number <> 0
            On Error GoTo 0
            canAdd = (LenB(tempFolder) > 0)
            tempURL = tempURL & tempFolder
        Case "AddedScope "
            If cFolders Is Nothing Then Set cFolders = GetODFolders(datPath)
            tempMount = mainMount & "\" & cFolders(Split(parts(0), " ")(3))
            tempURL = parts(5)
            temp = Split(parts(4), " ")
            tempURL = GetUrlNamespace(folderPath, "_" & temp(3) & temp(1) _
                                                      & temp(4)) & tempURL
            canAdd = True
        Case Else
            Exit For
        End Select
        If canAdd Then
            collLocalPaths.Add tempMount, tempURL
            collWebPaths.Add tempURL, tempMount
        End If
    Next lineText
End Sub
Private Function GetUrlNamespace(ByVal folderPath As String _
                               , Optional ByVal cSignature As String) As String
    Const nTag As String = "DavUrlNamespace"
    Dim bytes() As Byte
    Dim lineText As Variant
    '
    ReadBytes BuildPath(folderPath, "ClientPolicy" & cSignature & ".ini"), bytes
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, Len(nTag)) = nTag Then
            GetUrlNamespace = Mid$(lineText, InStr(Len(nTag), lineText, "https"))
            Exit Function
        End If
    Next lineText
End Function
Private Sub AddPersonalPaths(ByVal folderPath As String _
                           , ByVal collLocalPaths As Collection _
                           , ByVal collWebPaths As Collection)
    Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
    Dim iniPath As String
    Do
        iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
        If IsFile(iniPath) Then Exit Do
        datName = Dir
        If LenB(datName) = 0 Then Exit Sub
    Loop
    Dim mainURL As String: mainURL = GetUrlNamespace(folderPath) & "/"
    Dim cid As String:     cid = Replace(datName, ".dat", vbNullString)
    Dim tempURL As String: tempURL = mainURL & cid & "/"
    Dim bytes() As Byte:   ReadBytes iniPath, bytes
    Dim lineText As Variant
    Dim mainMount As String
    '
    For Each lineText In Split(bytes, vbNewLine)
        If Left$(lineText, InStr(1, lineText, " ")) = "library " Then
            mainMount = Split(lineText, """")(3) & "\"
            Exit For
        End If
    Next lineText
    collLocalPaths.Add mainMount, tempURL
    collWebPaths.Add tempURL, mainMount
    '
    Dim groupPath As String
    Dim i As Long
    Dim relPath As String
    Dim folderID As String
    Dim cFolders As Collection
    Dim tempMount As String
    '
    groupPath = BuildPath(folderPath, "GroupFolders.ini")
    If Not IsFile(groupPath) Then Exit Sub
    ReadBytes groupPath, bytes
    '
    For Each lineText In Split(bytes, vbNewLine)
        If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
            cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
            i = InStr(1, cid, "!")
            If i > 0 Then cid = Left$(cid, i - 1)
        Else
            i = InStr(1, lineText, "_Path", vbTextCompare)
            If i > 0 Then
                relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
                folderID = Left$(lineText, i - 1)
                If cFolders Is Nothing Then
                    Set cFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
                End If
                If cFolders.Count > 0 Then
                    tempMount = mainMount & cFolders(folderID)
                    tempURL = mainURL & cid & "/" & relPath
                    collLocalPaths.Add tempMount, tempURL
                    collWebPaths.Add tempURL, tempMount
                End If
            End If
        End If
    Next lineText
End Sub

'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
                            , Optional ByRef outParents As Collection) As Collection
    Dim b() As Byte:  ReadBytes filePath, b
    Dim s As String:  s = b
    Dim size As Long: size = LenB(s): If size = 0 Then Exit Function
    Dim i As Long
    Dim v As Variant
    Dim cFolders As New Collection
    Dim stepSize As Long
    Dim bytes As Long
    Dim folderID As String
    Dim parentID As String
    Dim folderName As String
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    Dim hFolder As String:    hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
    Dim hCheck As String:     hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x01..
    '
    If outParents Is Nothing Then Set outParents = New Collection
    For Each v In Array(16, 8)
        stepSize = v
        i = InStrB(stepSize, s, hCheck)
        Do While i > stepSize And i < size - 168
            If MidB$(s, i - stepSize, 1) = hFolder Then
                i = i + 8
                bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, 39)
                folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
                i = i + 39
                bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, 39)
                parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
                i = i + 121
                bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
                If bytes < 0 Then bytes = 0
                folderName = MidB$(s, i, bytes)
                If LenB(folderID) > 0 And LenB(parentID) > 0 Then
                    cFolders.Add folderName, folderID
                    outParents.Add parentID, folderID
                End If
            End If
            i = InStrB(i + 1, s, hCheck)
        Loop
        If cFolders.Count > 0 Then Exit For
    Next v
    Set GetODFolders = cFolders
End Function
Private Function Clamp(ByVal v As Long, ByVal lowB As Long, uppB As Long) As Long
    If v < lowB Then
        Clamp = lowB
    ElseIf v > uppB Then
        Clamp = uppB
    Else
        Clamp = v
    End If
End Function

'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
    Dim fileNumber As Long: fileNumber = FreeFile()
    Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
    '
    Open filePath For Binary Access Read As #fileNumber
    ReDim result(0 To LOF(fileNumber) - 1)
    Get fileNumber, , result
    Close #fileNumber
    '
    If mustDelete Then DeleteFile filePath
End Sub

[guwidoe]

Hi @cristianbuse,

I just tested your final solution and it still passes all my tests, I'm looking forward to seeing your updated library.

I consider the issue resolved and I will send you my final solution once I have time to complete it.

Thanks for everything! I have sent you a mail with my contact details and I'm looking forward to hearing from you!

[cristianbuse]

Thanks @guwidoe ,

Just realized that there is one more issue to solve. When iterating through the cache to find the correct mount, we must take into account the longest match.

For example, if both the following URLs are syncronized as different mounts:

1. https://d.docs.live.net/7efac79c174c1676/Test/
2. https://d.docs.live.net/7efac79c174c1676/Test/Test and it just happens that the cache has them in this same order then when looking for something like https://d.docs.live.net/7efac79c174c1676/Test/Test/test.txt then the result will be wrong as it will use the first match instead of the second (longest).

Just something to keep in mind when you finalize your solution. I will push with this fixed. I am not sure if this is applicable to GetLocalPath but is surely applicable to the viceversa GetWebPath

[guwidoe]

Hi @cristianbuse

I have thought about this already and I came to the conclusion that this is not a problem.

The reason is, that it is impossible to synchronize a child folder if you have already synchronized one of its parent folders. In your example, the mount https://d.docs.live.net/7efac79c174c1676/Test/Test can not exist because https://d.docs.live.net/7efac79c174c1676/Test/ is already mounted.

I recommend you try this out for yourself just in case I'm missing something, but I'm pretty sure I'm not.

[cristianbuse]

@guwidoe

You are correct, I just did that a few minutes ago. But I had to fix the viceversa logic as that is where the problem was.

[cristianbuse]

Many thanks @guwidoe ! Will keep in touch.