Cross-platform VBA Function to get the OneDrive/SharePoint Url path/link from a local path of a locally synced folder

GetOneDriveUrlPath.bas.vb

' Cross-platform VBA Function to get the OneDrive/SharePoint Url path (link)
' from a local path of a locally synced folder (Works on Windows and on macOS)
'
' Author: Guido Witt-Dörring
' Created: 2022/07/01
' Updated: 2024/04/15
' License: MIT
'
' ————————————————————————————————————————————————————————————————
' https://gist.github.com/guwidoe/6f0cbcd22850a360c623f235edd2dce2
' ————————————————————————————————————————————————————————————————
'
' Copyright (c) 2024 Guido Witt-Dörring
'
' MIT License:
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to
' deal in the Software without restriction, including without limitation the
' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
' sell copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in
' all copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
' IN THE SOFTWARE.

'———————————————————————————————————————————————————————————————————————————————
' COMMENTS REGARDING THE IMPLEMENTATION:
' This function works analogous to the 'GetLocalPath' function presented here:
' https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
' For more information about this function, please refer to that gist.
'———————————————————————————————————————————————————————————————————————————————

'———————————————————————————————————————————————————————————————————————————————
'COMMENTS REGARDING THE USAGE:
' Note:
' This function does not create a OneDrive 'share' link, to create such a link
' you need to use the Microsoft Graph API! The links created by this function
' will only work for the account that owns the remote folder that is being
' synchronized.

' This function offers an optional parameter to the user 'rebuildCache', however
' it is only meant to be used for recursive calls through the function itself.
' Using it is never necessary and will only lead to worse performance.
'———————————————————————————————————————————————————————————————————————————————

Option Explicit

'———————————————————————————————————————————————————————————————————————————————
'USAGE EXAMPLES:
Private Sub TestGetWebPath()
    Debug.Print "Local path: " & Environ("OneDrive")
    Debug.Print "Url path:   " & GetWebPath(Environ("OneDrive"))
    Debug.Print "Local path: " & Environ("OneDriveConsumer")
    Debug.Print "Url path:   " & GetWebPath(Environ("OneDriveConsumer"))
    Debug.Print "Local path: " & Environ("OneDriveCommercial")
    Debug.Print "Url path:   " & GetWebPath(Environ("OneDriveCommercial"))
End Sub
'———————————————————————————————————————————————————————————————————————————————

'Function for converting OneDrive/SharePoint Local Paths synchronized to
'OneDrive in any way to an OneDrive/SharePoint URL, containing for example
'.sharepoint.com/sites, my.sharepoint.com/personal/, or https://d.docs.live.net/
'depending on the type of OneDrive account and synchronization.
'If no url path can be found, the input value will be returned unmodified.
'Author: Guido Witt-Dörring
'Source: https://gist.github.com/guwidoe/6f0cbcd22850a360c623f235edd2dce2
Public Function GetWebPath(ByVal path As String, _
                  Optional ByVal rebuildCache As Boolean = False) _
                           As String
    #If Mac Then
        Const vbErrPermissionDenied            As Long = 70
        Const noErrJustDecodeUTF8              As Long = 20
        Const syncIDFileName As String = ".849C9593-D756-4E56-8D6E-42412F2A707B"
        Const isMac As Boolean = True
        Const ps As String = "/" 'Application.PathSeparator doesn't work
    #Else 'Windows               'in all host applications (e.g. Outlook), hence
        Const ps As String = "\" 'conditional compilation is preferred here.
        Const isMac As Boolean = False
    #End If
    Const methodName As String = "GetWebPath"
    Const vbErrFileNotFound                As Long = 53
    Const vbErrOutOfMemory                 As Long = 7
    Const vbErrKeyAlreadyExists            As Long = 457
    Const vbErrInvalidFormatInResourceFile As Long = 325
    
    Static locToWebColl As Collection, lastCacheUpdate As Date
    
    If path Like "http*" Then GetWebPath = path: Exit Function
    
    Dim webRoot As String, locRoot As String, vItem As Variant
    Dim s As String, keyExists As Boolean
    If Not locToWebColl Is Nothing And Not rebuildCache Then
        'If the locToWebDict is initialized, this logic will find the Url
        locRoot = path: GetWebPath = ""
        If locRoot Like "*" & ps Then locRoot = Left(locRoot, Len(locRoot) - 1)
        Do
            On Error Resume Next: locToWebColl locRoot: keyExists = _
            (Err.Number = 0): On Error GoTo 0
            If keyExists Or InStr(locRoot, ps) = 0 Then Exit Do
            locRoot = Left(locRoot, InStrRev(locRoot, ps) - 1)
        Loop
        If InStr(locRoot, ps) > 0 Then _
            GetWebPath = Replace(Replace(path, locRoot, _
                         locToWebColl(locRoot)(1), , 1), ps, "/"): Exit Function
        'Web path was not found with cached mountpoints
        GetWebPath = path 'No Exit Function here! Check if cache needs rebuild
    End If 'From here on, this function is identical with GetLocalPath, except
    'GetLocalPath -> GetWebPath

    Dim settPaths As Collection: Set settPaths = New Collection
    Dim settPath As Variant, clpPath As String
    #If Mac Then 'The settings directories can be in different locations
        Dim cloudStoragePath As String, cloudStoragePathExists As Boolean
        s = Environ("HOME")
        clpPath = s & "/Library/Application Support/Microsoft/Office/CLP/"
        s = Left$(s, InStrRev(s, "/Library/Containers/", , vbBinaryCompare))
        settPaths.Add s & _
                      "Library/Containers/com.microsoft.OneDrive-mac/Data/" & _
                      "Library/Application Support/OneDrive/settings/"
        settPaths.Add s & "Library/Application Support/OneDrive/settings/"
        cloudStoragePath = s & "Library/CloudStorage/"

        'Excels CLP folder:
        'clpPath = Left$(s, InStrRev(s, "/Library/Containers", , 0)) & _
                  "Library/Containers/com.microsoft.Excel/Data/" & _
                  "Library/Application Support/Microsoft/Office/CLP/"
    #Else 'On Windows, the settings directories are always in this location:
        settPaths.Add Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
        clpPath = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
    #End If

    Dim i As Long
    #If Mac Then 'Request access to all possible directories at once
        Dim arrDirs() As Variant: ReDim arrDirs(1 To settPaths.count * 11 + 1)
        For Each settPath In settPaths
            For i = i + 1 To i + 9
                arrDirs(i) = settPath & "Business" & i Mod 11
            Next i
            arrDirs(i) = settPath: i = i + 1
            arrDirs(i) = settPath & "Personal"
        Next settPath
        arrDirs(i + 1) = cloudStoragePath
        Dim accessRequestInfoMsgShown As Boolean
        accessRequestInfoMsgShown = getsetting("GetLocalPath", _
                        "AccessRequestInfoMsg", "Displayed", "False") = "True"
        If Not accessRequestInfoMsgShown Then MsgBox "The current " _
            & "VBA Project requires access to the OneDrive settings files to " _
            & "translate a OneDrive URL to the local path of the locally " & _
            "synchronized file/folder on your Mac. Because these files are " & _
            "located outside of Excels sandbox, file-access must be granted " _
            & "explicitly. Please approve the access requests following this " _
            & "message.", vbInformation
        If Not GrantAccessToMultipleFiles(arrDirs) Then _
            Err.Raise vbErrPermissionDenied, methodName
    #End If

    'Find all subdirectories in OneDrive settings folder:
    Dim oneDriveSettDirs As Collection: Set oneDriveSettDirs = New Collection
    For Each settPath In settPaths
        Dim dirName As String: dirName = Dir(settPath, vbDirectory)
        Do Until dirName = vbNullString
            If dirName = "Personal" Or dirName Like "Business#" Then _
                oneDriveSettDirs.Add Item:=settPath & dirName & ps
            dirName = Dir(, vbDirectory)
        Loop
    Next settPath

    If Not locToWebColl Is Nothing Or isMac Then
        Dim requiredFiles As Collection: Set requiredFiles = New Collection
        'Get collection of all required files
        Dim vDir As Variant
        For Each vDir In oneDriveSettDirs
            Dim cid As String: cid = IIf(vDir Like "*" & ps & "Personal" & ps, _
                                         "????????????*", _
                                         "????????-????-????-????-????????????")
            Dim fileName As String: fileName = Dir(vDir, vbNormal)
            Do Until fileName = vbNullString
                If fileName Like cid & ".ini" _
                Or fileName Like cid & ".dat" _
                Or fileName Like "ClientPolicy*.ini" _
                Or StrComp(fileName, "GroupFolders.ini", vbTextCompare) = 0 _
                Or StrComp(fileName, "global.ini", vbTextCompare) = 0 _
                Or StrComp(fileName, "SyncEngineDatabase.db", _
                           vbTextCompare) = 0 Then _
                    requiredFiles.Add Item:=vDir & fileName
                fileName = Dir
            Loop
        Next vDir
    End If

    'This part should ensure perfect accuracy despite the mount point cache
    'while sacrificing almost no performance at all by querying FileDateTimes.
    If Not locToWebColl Is Nothing And Not rebuildCache Then
        'Check if a settings file was modified since the last cache rebuild
        Dim vFile As Variant
        For Each vFile In requiredFiles
            If FileDateTime(vFile) > lastCacheUpdate Then _
                rebuildCache = True: Exit For 'full cache refresh is required!
        Next vFile
        If Not rebuildCache Then Exit Function
    End If

    'If execution reaches this point, the cache will be fully rebuilt...
    Dim fileNum As Long, syncID As String, b() As Byte, j As Long, k As Long
    'Variables for manual decoding of UTF-8, UTF-32 and ANSI
    Dim m As Long, ansi() As Byte, sAnsi As String
    Dim utf16() As Byte, sUtf16 As String, utf32() As Byte
    Dim utf8() As Byte, sUtf8 As String, numBytesOfCodePoint As Long
    Dim codepoint As Long, lowSurrogate As Long, highSurrogate As Long

    lastCacheUpdate = Now()
    #If Mac Then 'Prepare building syncIDtoSyncDir dictionary. This involves
        'reading the ".849C9593-D756-4E56-8D6E-42412F2A707B" files inside the
        'subdirs of "~/Library/CloudStorage/", list of files and access required
        Dim coll As Collection: Set coll = New Collection
        dirName = Dir(cloudStoragePath, vbDirectory)
        Do Until dirName = vbNullString
            If dirName Like "OneDrive*" Then
                cloudStoragePathExists = True
                vDir = cloudStoragePath & dirName & ps
                vFile = cloudStoragePath & dirName & ps & syncIDFileName
                coll.Add Item:=vDir
                requiredFiles.Add Item:=vDir 'For pooling file access requests
                requiredFiles.Add Item:=vFile
            End If
            dirName = Dir(, vbDirectory)
        Loop

        'Pool access request for these files and the OneDrive/settings files
        If locToWebColl Is Nothing Then
            Dim vFiles As Variant
            If requiredFiles.count > 0 Then
                ReDim vFiles(1 To requiredFiles.count)
               For i = 1 To UBound(vFiles): vFiles(i) = requiredFiles(i): Next i
                If Not GrantAccessToMultipleFiles(vFiles) Then _
                    Err.Raise vbErrPermissionDenied, methodName
            End If
        End If

        'More access might be required if some folders inside cloudStoragePath
        'don't contain the hidden file ".849C9593-D756-4E56-8D6E-42412F2A707B".
        'In that case, access to their first level subfolders is also required.
        If cloudStoragePathExists Then
            For i = coll.count To 1 Step -1
                Dim fAttr As Long: fAttr = 0
                On Error Resume Next
                fAttr = GetAttr(coll(i) & syncIDFileName)
                Dim IsFile As Boolean: IsFile = False
                If Err.Number = 0 Then IsFile = Not CBool(fAttr And vbDirectory)
                On Error GoTo 0
                If Not IsFile Then 'hidden file does not exist
                'Dir(path, vbHidden) is unreliable and doesn't work on some Macs
                'If Dir(coll(i) & syncIDFileName, vbHidden) = vbNullString Then
                    dirName = Dir(coll(i), vbDirectory)
                    Do Until dirName = vbNullString
                        If Not dirName Like ".Trash*" And dirName <> "Icon" Then
                            coll.Add coll(i) & dirName & ps
                            coll.Add coll(i) & dirName & ps & syncIDFileName, _
                                     coll(i) & dirName & ps  '<- key for removal
                        End If
                        dirName = Dir(, vbDirectory)
                    Loop          'Remove the
                    coll.Remove i 'folder if it doesn't contain the hidden file.
                End If
            Next i
            If coll.count > 0 Then
                ReDim arrDirs(1 To coll.count)
                For i = 1 To coll.count: arrDirs(i) = coll(i): Next i
                If Not GrantAccessToMultipleFiles(arrDirs) Then _
                    Err.Raise vbErrPermissionDenied, methodName
            End If
            'Remove all files from coll (not the folders!): Reminder:
            On Error Resume Next 'coll(coll(i)) = coll(i) & syncIDFileName
            For i = coll.count To 1 Step -1
                coll.Remove coll(i)
            Next i
            On Error GoTo 0

            'Write syncIDtoSyncDir collection
            Dim syncIDtoSyncDir As Collection
            Set syncIDtoSyncDir = New Collection
            For Each vDir In coll
                fAttr = 0
                On Error Resume Next
                fAttr = GetAttr(vDir & syncIDFileName)
                IsFile = False
                If Err.Number = 0 Then IsFile = Not CBool(fAttr And vbDirectory)
                On Error GoTo 0
                If IsFile Then 'hidden file exists
                'Dir(path, vbHidden) is unreliable and doesn't work on some Macs
                'If Dir(vDir & syncIDFileName, vbHidden) <> vbNullString Then
                    fileNum = FreeFile(): s = "": vFile = vDir & syncIDFileName
                    'Somehow reading these files with "Open" doesn't always work
                    Dim readSucceeded As Boolean: readSucceeded = False
                    On Error GoTo ReadFailed
                    Open vFile For Binary Access Read As #fileNum
                        ReDim b(0 To LOF(fileNum)): Get fileNum, , b: s = b
                        readSucceeded = True
ReadFailed:             On Error GoTo -1
                    Close #fileNum: fileNum = 0
                    On Error GoTo 0
                    If readSucceeded Then
                        'Debug.Print "Used open statement to read file: " & _
                                    vDir & syncIDFileName
                        ansi = s 'If Open was used: Decode ANSI string manually:
                        If LenB(s) > 0 Then
                            ReDim utf16(0 To LenB(s) * 2 - 1): k = 0
                            For j = LBound(ansi) To UBound(ansi)
                                utf16(k) = ansi(j): k = k + 2
                            Next j
                            s = utf16
                        Else: s = vbNullString
                        End If
                    Else 'Reading the file with "Open" failed with an error. Try
                        'using AppleScript. Also avoids the manual transcoding.
                        'Somehow ApplScript fails too, sometimes. Seems whenever
                        '"Open" works, AppleScript fails and vice versa (?!?!)
                        vFile = MacScript("return path to startup disk as " & _
                                    "string") & Replace(Mid$(vFile, 2), ps, ":")
                        s = MacScript("return read file """ & _
                                      vFile & """ as string")
                       'Debug.Print "Used Apple Script to read file: " & vFile
                    End If
                    If InStr(1, s, """guid"" : """, vbBinaryCompare) Then
                        s = Split(s, """guid"" : """)(1)
                        syncID = Left$(s, InStr(1, s, """", 0) - 1)
                        syncIDtoSyncDir.Add Key:=syncID, _
                             Item:=VBA.Array(syncID, Left$(vDir, Len(vDir) - 1))
                    Else
                        Debug.Print "Warning, empty syncIDFile encountered!"
                    End If
                End If
            Next vDir
        End If
        'Now all access requests have succeeded
        If Not accessRequestInfoMsgShown Then savesetting _
            "GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"
    #End If

    'Declare some variables that will be used in the loop over OneDrive settings
    Dim line As Variant, parts() As String, n As Long, libNr As String
    Dim tag As String, mainMount As String, relPath As String, email As String
    Dim parentID As String, folderID As String, folderName As String
    Dim idPattern As String, folderType As String
    Dim siteID As String, libID As String, webID As String, lnkID As String
    Dim mainSyncID As String, syncFind As String, mainSyncFind As String
    'The following are "constants" and needed for reading the .dat files:
    Dim sig1 As String:       sig1 = ChrB$(2)
    Dim sig2 As String * 4:   MidB$(sig2, 1) = ChrB$(1)
    Dim vbNullByte As String: vbNullByte = ChrB$(0)
    #If Mac Then
        Const sig3 As String = vbNullChar & vbNullChar
    #Else 'Windows
        Const sig3 As String = vbNullChar
    #End If

    'Writing locToWebColl using .ini and .dat files in the OneDrive settings:
    'Here, a Scripting.Dictionary would be nice but it is not available on Mac!
    Dim lastAccountUpdates As Collection, lastAccountUpdate As Date
    Set lastAccountUpdates = New Collection
    Set locToWebColl = New Collection
    For Each vDir In oneDriveSettDirs 'One folder per logged in OD account
        dirName = Mid$(vDir, InStrRev(vDir, ps, Len(vDir) - 1, 0) + 1)
        dirName = Left$(dirName, Len(dirName) - 1)

        'Read global.ini to get cid
        If Dir(vDir & "global.ini", vbNormal) = "" Then GoTo NextFolder
        fileNum = FreeFile()
        Open vDir & "global.ini" For Binary Access Read As #fileNum
            ReDim b(0 To LOF(fileNum)): Get fileNum, , b
        Close #fileNum: fileNum = 0
        #If Mac Then 'On Mac, the OneDrive settings files use UTF-8 encoding
            sUtf8 = b: GoSub DecodeUTF8
            b = sUtf16
        #End If
        For Each line In Split(b, vbNewLine)
            If line Like "cid = *" Then cid = Mid$(line, 7): Exit For
        Next line

        If cid = vbNullString Then GoTo NextFolder
        If (Dir(vDir & cid & ".ini") = vbNullString Or _
           (Dir(vDir & "SyncEngineDatabase.db") = vbNullString And _
            Dir(vDir & cid & ".dat") = vbNullString)) Then GoTo NextFolder
        If dirName Like "Business#" Then
            idPattern = Replace(Space$(32), " ", "[a-f0-9]") & "*"
        ElseIf dirName = "Personal" Then
            idPattern = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"
        End If
        'Alternatively maybe a general pattern like this performs better:
        'idPattern = Replace(Space$(12), " ", "[a-fA-F0-9]") & "*"

        'Get email for business accounts
        '(only necessary to let user choose preferredMountPointOwner)
        fileName = Dir(clpPath, vbNormal)
        Do Until fileName = vbNullString
            i = InStrRev(fileName, cid, , vbTextCompare)
            If i > 1 And cid <> vbNullString Then _
                email = LCase$(Left$(fileName, i - 2)): Exit Do
            fileName = Dir
        Loop

        #If Mac Then
            On Error Resume Next
            lastAccountUpdate = lastAccountUpdates(dirName)
            keyExists = (Err.Number = 0)
            On Error GoTo 0
            If keyExists Then
                If FileDateTime(vDir & cid & ".ini") < lastAccountUpdate Then
                    GoTo NextFolder
                Else
                    For i = locToWebColl.count To 1 Step -1
                        If locToWebColl(i)(5) = dirName Then
                            locToWebColl.Remove i
                        End If
                    Next i
                    lastAccountUpdates.Remove dirName
                    lastAccountUpdates.Add Key:=dirName, _
                                         Item:=FileDateTime(vDir & cid & ".ini")
                End If
            Else
                lastAccountUpdates.Add Key:=dirName, _
                                      Item:=FileDateTime(vDir & cid & ".ini")
            End If
        #End If

        'Read all the ClientPloicy*.ini files:
        Dim cliPolColl As Collection: Set cliPolColl = New Collection
        fileName = Dir(vDir, vbNormal)
        Do Until fileName = vbNullString
            If fileName Like "ClientPolicy*.ini" Then
                fileNum = FreeFile()
                Open vDir & fileName For Binary Access Read As #fileNum
                    ReDim b(0 To LOF(fileNum)): Get fileNum, , b
                Close #fileNum: fileNum = 0
                #If Mac Then 'On Mac, OneDrive settings files use UTF-8 encoding
                    sUtf8 = b: GoSub DecodeUTF8
                    b = sUtf16
                #End If
                cliPolColl.Add Key:=fileName, Item:=New Collection
                For Each line In Split(b, vbNewLine)
                    If InStr(1, line, " = ", vbBinaryCompare) Then
                        tag = Left$(line, InStr(1, line, " = ", 0) - 1)
                        s = Mid$(line, InStr(1, line, " = ", 0) + 3)
                        Select Case tag
                        Case "DavUrlNamespace"
                            cliPolColl(fileName).Add Key:=tag, Item:=s
                        Case "SiteID", "IrmLibraryId", "WebID" 'Only used for
                            s = Replace(LCase$(s), "-", "") 'backup method later
                            If Len(s) > 3 Then s = Mid$(s, 2, Len(s) - 2)
                            cliPolColl(fileName).Add Key:=tag, Item:=s
                        End Select
                    End If
                Next line
            End If
            fileName = Dir
        Loop

        'If cid.dat file doesn't exist, skip this part:
        Dim odFolders As Collection: Set odFolders = Nothing
        If Dir(vDir & cid & ".dat") = vbNullString Then GoTo Continue

        'Read cid.dat file if it exists:
        Const chunkOverlap          As Long = 1000
        Const maxDirName            As Long = 255
        Dim buffSize As Long: buffSize = -1 'Buffer uninitialized
Try:    On Error GoTo Catch
        Set odFolders = New Collection
        Dim lastChunkEndPos As Long: lastChunkEndPos = 1
        Dim lastFileUpdate As Date:  lastFileUpdate = FileDateTime(vDir & _
                                                                   cid & ".dat")
        i = 0 'i = current reading pos.
        Do
            'Ensure file is not changed while reading it
            If FileDateTime(vDir & cid & ".dat") > lastFileUpdate Then GoTo Try
            fileNum = FreeFile
            Open vDir & cid & ".dat" For Binary Access Read As #fileNum
                Dim lenDatFile As Long: lenDatFile = LOF(fileNum)
                If buffSize = -1 Then buffSize = lenDatFile 'Initialize buffer
                'Overallocate a bit so read chunks overlap to recognize all dirs
                ReDim b(0 To buffSize + chunkOverlap)
                Get fileNum, lastChunkEndPos, b: s = b
                Dim size As Long: size = LenB(s)
            Close #fileNum: fileNum = 0
            lastChunkEndPos = lastChunkEndPos + buffSize

            For vItem = 16 To 8 Step -8
                i = InStrB(vItem + 1, s, sig2, 0) 'Sarch pattern in cid.dat
                Do While i > vItem And i < size - 168 'and confirm with another
                    If StrComp(MidB$(s, i - vItem, 1), sig1, 0) = 0 Then 'one
                        i = i + 8: n = InStrB(i, s, vbNullByte, 0) - i
                        If n < 0 Then n = 0           'i:Start pos, n: Length
                        If n > 39 Then n = 39
                        #If Mac Then 'StrConv doesn't work reliably on Mac ->
                            sAnsi = MidB$(s, i, n) 'Decode ANSI string manually:
                            GoSub DecodeANSI: folderID = sUtf16
                        #Else 'Windows
                            folderID = StrConv(MidB$(s, i, n), vbUnicode)
                        #End If
                        i = i + 39: n = InStrB(i, s, vbNullByte, 0) - i
                        If n < 0 Then n = 0
                        If n > 39 Then n = 39
                        #If Mac Then 'StrConv doesn't work reliably on Mac ->
                            sAnsi = MidB$(s, i, n) 'Decode ANSI string manually:
                            GoSub DecodeANSI: parentID = sUtf16
                        #Else 'Windows
                            parentID = StrConv(MidB$(s, i, n), vbUnicode)
                        #End If
                        i = i + 121
                       n = InStr(-Int(-(i - 1) / 2) + 1, s, sig3, 0) * 2 - i - 1
                        If n > maxDirName * 2 Then n = maxDirName * 2
                        If n < 0 Then n = 0
                        If folderID Like idPattern _
                        And parentID Like idPattern Then
                            #If Mac Then 'Encoding of folder names is UTF-32-LE
                                Do While n Mod 4 > 0
                                    If n > maxDirName * 4 Then Exit Do
                                    n = InStr(-Int(-(i + n) / 2) + 1, s, sig3, _
                                              0) * 2 - i - 1
                                Loop
                                If n > maxDirName * 4 Then n = maxDirName * 4
                                utf32 = MidB$(s, i, n)
                                'UTF-32 can only be converted manually to UTF-16
                                ReDim utf16(LBound(utf32) To UBound(utf32))
                                j = LBound(utf32): k = LBound(utf32)
                                Do While j < UBound(utf32)
                                    If utf32(j + 2) + utf32(j + 3) = 0 Then
                                        utf16(k) = utf32(j)
                                        utf16(k + 1) = utf32(j + 1)
                                        k = k + 2
                                    Else
                                        If utf32(j + 3) <> 0 Then Err.Raise _
                                            vbErrInvalidFormatInResourceFile, _
                                            methodName
                                        codepoint = utf32(j + 2) * &H10000 + _
                                                    utf32(j + 1) * &H100& + _
                                                    utf32(j)
                                        m = codepoint - &H10000
                                        highSurrogate = &HD800& Or (m \ &H400&)
                                        lowSurrogate = &HDC00& Or (m And &H3FF)
                                        utf16(k) = highSurrogate And &HFF&
                                        utf16(k + 1) = highSurrogate \ &H100&
                                        utf16(k + 2) = lowSurrogate And &HFF&
                                        utf16(k + 3) = lowSurrogate \ &H100&
                                        k = k + 4
                                    End If
                                    j = j + 4
                                Loop
                                If k > LBound(utf16) Then
                                    ReDim Preserve utf16(LBound(utf16) To k - 1)
                                    folderName = utf16
                                Else: folderName = vbNullString
                                End If
                            #Else 'On Windows encoding is UTF-16-LE
                                folderName = MidB$(s, i, n)
                            #End If
                            'VBA.Array() instead of just Array() is used in this
                            'function because it ignores Option Base 1
                            odFolders.Add VBA.Array(parentID, folderName), _
                                          folderID
                        End If
                    End If
                    i = InStrB(i + 1, s, sig2, 0) 'Find next sig2 in cid.dat
                Loop
                If odFolders.count > 0 Then Exit For
            Next vItem
        Loop Until lastChunkEndPos >= lenDatFile _
                Or buffSize >= lenDatFile
        GoTo Continue
Catch:
        Select Case Err.Number
        Case vbErrKeyAlreadyExists
            'This can happen at chunk boundries, folder might get added twice:
            odFolders.Remove folderID 'Make sure the folder gets added new again
            Resume 'to avoid folderNames truncated by chunk ends
        Case Is <> vbErrOutOfMemory: Err.Raise Err, methodName
        End Select
        If buffSize > &HFFFFF Then buffSize = buffSize / 2: Resume Try
        Err.Raise Err, methodName 'Raise error if less than 1 MB RAM available
Continue:
        On Error GoTo 0
        'If .dat file didn't exist, read db file, otherwise skip this part
        If Not odFolders Is Nothing Then GoTo SkipDbFile
        'The following code for reading the .db file is an adaptation of the
        'original code by Cristian Buse, see procedure 'GetODDirsFromDB' in the
        'repository: https://github.com/cristianbuse/VBA-FileTools
        fileNum = FreeFile()
        Open vDir & "SyncEngineDatabase.db" For Binary Access Read As #fileNum
        size = LOF(fileNum)
        If size = 0 Then GoTo CloseFile
        '                             __    ____
        'Signature bytes: 0b0b0b0b0b0b080b0b08080b0b0b0b where b>=0, b <= 9
        Dim sig88 As String: sig88 = ChrW$(&H808)
        Const sig8 As Long = 8
        Const sig8Offset As Long = -3
        Const maxSigByte As Byte = 9
        Const sig88ToDataOffset As Long = 6 'Data comes after the signature
        Const headBytes6 As Long = &H16
        Const headBytes5 As Long = &H15
        Const headBytes6Offset As Long = -16 'Header comes before the signature
        Const headBytes5Offset As Long = -15
        Const chunkSize As Long = &H100000 '1MB

        Dim lastRecord As Long, bytes As Long, nameSize As Long
        Dim idSize(1 To 4) As Byte
        Dim lastFolderID As String, lastParentID As String
        Dim lastNameStart As Long
        Dim lastNameSize As Long
        Dim currDataEnd As Long, lastDataEnd As Long
        Dim headByte As Byte, lastHeadByte As Byte
        Dim has5HeadBytes As Boolean
        Dim extraOffset As Long

        lastFileUpdate = 0
        ReDim b(1 To chunkSize)
        Do
            i = 0
           If FileDateTime(vDir & "SyncEngineDatabase.db") > lastFileUpdate Then
                Set odFolders = New Collection
                Dim heads As Collection: Set heads = New Collection

                lastFileUpdate = FileDateTime(vDir & "SyncEngineDatabase.db")
                lastRecord = 1
                lastFolderID = vbNullString
            End If
            If LenB(lastFolderID) > 0 Then
                folderName = MidB$(s, lastNameStart, lastNameSize)
            End If
            Get fileNum, lastRecord, b
            s = b
            i = InStrB(1 - headBytes6Offset, s, sig88, vbBinaryCompare)
            lastDataEnd = 0
            Do While i > 0
                If i + headBytes6Offset - 2 > lastDataEnd _
                And LenB(lastFolderID) > 0 Then
                    If lastDataEnd > 0 Then
                        folderName = MidB$(s, lastNameStart, lastNameSize)
                    End If
                    sUtf8 = folderName: GoSub DecodeUTF8
                    folderName = sUtf16
                    On Error Resume Next
                    odFolders.Add VBA.Array(lastParentID, folderName), _
                                            lastFolderID
                    If Err.Number <> 0 Then
                        If heads(lastFolderID) < lastHeadByte Then
                            If odFolders(lastFolderID)(1) <> folderName _
                            Or odFolders(lastFolderID)(0) <> lastParentID Then
                                odFolders.Remove lastFolderID
                                heads.Remove lastFolderID
                                odFolders.Add VBA.Array(lastParentID, _
                                                        folderName), _
                                              lastFolderID
                            End If
                        End If
                    End If
                    heads.Add lastHeadByte, lastFolderID
                    On Error GoTo 0
                    lastFolderID = vbNullString
                End If

                If b(i + sig8Offset) <> sig8 Then GoTo NextSig
                has5HeadBytes = True
                extraOffset = 0
                If b(i + headBytes5Offset) = headBytes5 Then
                    j = i + headBytes5Offset
                ElseIf b(i + headBytes6Offset) = headBytes6 Then
                    j = i + headBytes6Offset
                    has5HeadBytes = False 'Has 6 bytes header
                ElseIf b(i + headBytes5Offset) <= maxSigByte Then
                    j = i + headBytes5Offset
                ElseIf b(i + headBytes5Offset) = headBytes6 Then
                    j = i + headBytes5Offset
                    extraOffset = 1
                Else
                    GoTo NextSig
                End If
                headByte = b(j)

                bytes = sig88ToDataOffset
                For k = 1 To 4
                    If k = 1 And headByte <= maxSigByte Then
                        idSize(k) = b(j + 2) 'Ignore first header byte
                    Else
                        idSize(k) = b(j + k)
                    End If
                    If idSize(k) < 37 Or idSize(k) Mod 2 = 0 Then GoTo NextSig
                    idSize(k) = (idSize(k) - 13) / 2
                    bytes = bytes + idSize(k)
                Next k
                If has5HeadBytes Then
                    nameSize = b(j + 5)
                    If nameSize < 15 Or nameSize Mod 2 = 0 Then GoTo NextSig
                    nameSize = (nameSize - 13) / 2
                Else
                    nameSize = (b(j + 5) - 128) * 64 + (b(j + 6) - 13) / 2
                    If nameSize < 1 Or b(j + 6) Mod 2 = 0 Then GoTo NextSig
                End If
                bytes = bytes + nameSize

                currDataEnd = i + bytes - 1
                If currDataEnd > chunkSize Then 'Next chunk
                    i = i - 1
                    Exit Do
                End If
                j = i + sig88ToDataOffset + extraOffset
                #If Mac Then 'StrConv doesn't work reliably on Mac ->
                    sAnsi = MidB$(s, j, idSize(1)) 'Decode ANSI string manually:
                    GoSub DecodeANSI: folderID = sUtf16
                #Else 'Windows
                    folderID = StrConv(MidB$(s, j, idSize(1)), vbUnicode)
                #End If
                j = j + idSize(1)
                parentID = StrConv(MidB$(s, j, idSize(2)), vbUnicode)
                #If Mac Then 'StrConv doesn't work reliably on Mac ->
                    sAnsi = MidB$(s, j, idSize(2)) 'Decode ANSI string manually:
                    GoSub DecodeANSI: parentID = sUtf16
                #Else 'Windows
                    parentID = StrConv(MidB$(s, j, idSize(2)), vbUnicode)
                #End If

                If folderID Like idPattern And parentID Like idPattern Then
                    lastNameStart = j + idSize(2) + idSize(3) + idSize(4)
                    lastNameSize = nameSize
                    lastFolderID = Left$(folderID, 32) 'Ignore the "+#.." in IDs
                    lastParentID = Left$(parentID, 32) 'of Business OneDrive
                    lastHeadByte = headByte
                    lastDataEnd = currDataEnd
                End If
NextSig:
                i = InStrB(i + 1, s, sig88, vbBinaryCompare)
            Loop
            If i = 0 Then
                lastRecord = lastRecord + chunkSize + headBytes6Offset
            Else
                lastRecord = lastRecord + i + headBytes6Offset
            End If
        Loop Until lastRecord > size
CloseFile:
        Close #fileNum
SkipDbFile:
        'Read cid.ini file
        fileNum = FreeFile()
        Open vDir & cid & ".ini" For Binary Access Read As #fileNum
            ReDim b(0 To LOF(fileNum)): Get fileNum, , b
        Close #fileNum: fileNum = 0
        #If Mac Then 'On Mac, the OneDrive settings files use UTF-8 encoding
            sUtf8 = b: GoSub DecodeUTF8:
            b = sUtf16
        #End If 'The lines from cid.ini are out of order on some systems:
        Dim sortedLines As Collection: Set sortedLines = New Collection
        Dim possTags As Variant 'Must be ordered correctly in the Array!
        possTags = VBA.Array("libraryScope", "libraryFolder", "AddedScope")
        Dim bucketColl As Collection: Set bucketColl = New Collection
        For Each vItem In possTags
            bucketColl.Add New Collection, CStr(vItem)
        Next vItem
        For Each line In Split(b, vbNewLine)
            If InStr(1, line, " = ", vbBinaryCompare) = 0 Then Exit For
            tag = Left$(line, InStr(1, line, " = ", 0) - 1)
            Select Case tag: Case "libraryScope", "libraryFolder", "AddedScope"
                bucketColl(tag).Add line, Split(line, " ", 4, 0)(2)
            End Select
        Next line
        For Each vItem In possTags 'Build the sortedLines collection
            Dim tagColl As Collection: Set tagColl = bucketColl(vItem)
            i = 0
            Do Until tagColl.count = 0
                On Error Resume Next
                line = vbNullString: line = tagColl(CStr(i))
                On Error GoTo 0
                If line <> vbNullString Then
                    sortedLines.Add line
                    tagColl.Remove CStr(i)
                End If
                i = i + 1
            Loop
        Next vItem
        If dirName Like "Business#" Then 'Settings files for business OD account
        'Max 9 Business OneDrive accounts can be signed in at a time.
           Dim libNrToWebColl As Collection: Set libNrToWebColl = New Collection
            mainMount = vbNullString
            For Each line In sortedLines '= Split(b, vbNewLine), but sorted
                webRoot = "": locRoot = "": parts = Split(line, """")
                Select Case Left$(line, InStr(1, line, " = ", 0) - 1) '(tag)
                Case "libraryScope" 'One line per synchronized library
                    locRoot = parts(9)
                    syncFind = locRoot: syncID = Split(parts(10), " ")(2)
                    libNr = Split(line, " ")(2)
                    folderType = parts(3): parts = Split(parts(8), " ")
                    siteID = parts(1): webID = parts(2): libID = parts(3)
                    If Split(line, " ", 4, vbBinaryCompare)(2) = "0" Then
                        mainMount = locRoot: fileName = "ClientPolicy.ini"
                        mainSyncID = syncID: mainSyncFind = syncFind
                    Else: fileName = "ClientPolicy_" & libID & siteID & ".ini"
                    End If
                    On Error Resume Next 'On error try backup method...
                    webRoot = cliPolColl(fileName)("DavUrlNamespace")
                    On Error GoTo 0
                    If webRoot = "" Then 'Backup method to find webRoot:
                        For Each vItem In cliPolColl
                            If vItem("SiteID") = siteID _
                            And vItem("WebID") = webID _
                            And vItem("IrmLibraryId") = libID Then
                                webRoot = vItem("DavUrlNamespace"): Exit For
                            End If
                        Next vItem
                    End If
                    If webRoot = vbNullString Then Err.Raise vbErrFileNotFound _
                                                           , methodName
                    libNrToWebColl.Add VBA.Array(libNr, webRoot), libNr
                    If Not locRoot = vbNullString Then _
                        locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
                                        syncID, syncFind, dirName), Key:=locRoot
                Case "libraryFolder" 'One line per synchronized library folder
                    libNr = Split(line, " ")(3)
                    locRoot = parts(1): syncFind = locRoot
                    syncID = Split(parts(4), " ")(1)
                    s = vbNullString: parentID = Left$(Split(line, " ")(4), 32)
                    Do  'If not synced at the bottom dir of the library:
                        '   -> add folders below mount point to webRoot
                        On Error Resume Next: odFolders parentID
                        keyExists = (Err.Number = 0): On Error GoTo 0
                        If Not keyExists Then Exit Do
                        s = odFolders(parentID)(1) & "/" & s
                        parentID = odFolders(parentID)(0)
                    Loop
                    webRoot = libNrToWebColl(libNr)(1) & s
                    locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
                                             syncID, syncFind, dirName), locRoot
                Case "AddedScope" 'One line per folder added as link to personal
                    If mainMount = vbNullString Then _
                        Err.Raise vbErrInvalidFormatInResourceFile, methodName
                    relPath = parts(5): If relPath = " " Then relPath = ""  'lib
                    parts = Split(parts(4), " "): siteID = parts(1)
                    webID = parts(2): libID = parts(3): lnkID = parts(4)
                    fileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini"
                    On Error Resume Next 'On error try backup method...
                    webRoot = cliPolColl(fileName)("DavUrlNamespace") & relPath
                    On Error GoTo 0
                    If webRoot = "" Then 'Backup method to find webRoot:
                        For Each vItem In cliPolColl
                            If vItem("SiteID") = siteID _
                            And vItem("WebID") = webID _
                            And vItem("IrmLibraryId") = libID Then
                                webRoot = vItem("DavUrlNamespace") & relPath
                                Exit For
                            End If
                        Next vItem
                    End If
                    If webRoot = vbNullString Then Err.Raise vbErrFileNotFound _
                                                           , methodName
                    s = vbNullString: parentID = Left$(Split(line, " ")(3), 32)
                    Do 'If link is not at the bottom of the personal library:
                        On Error Resume Next: odFolders parentID
                        keyExists = (Err.Number = 0): On Error GoTo 0
                        If Not keyExists Then Exit Do       'add folders below
                        s = odFolders(parentID)(1) & ps & s 'mount point to
                        parentID = odFolders(parentID)(0)   'locRoot
                    Loop
                    locRoot = mainMount & ps & s
                    locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
                                     mainSyncID, mainSyncFind, dirName), locRoot
                Case Else: Exit For
                End Select
            Next line
        ElseIf dirName = "Personal" Then 'Settings files for personal OD account
        'Only one Personal OneDrive account can be signed in at a time.
            For Each line In Split(b, vbNewLine) 'Loop should exit at first line
                If line Like "library = *" Then
                    parts = Split(line, """"): locRoot = parts(3)
                    syncFind = locRoot: syncID = Split(parts(4), " ")(2)
                    Exit For
                End If
            Next line
            On Error Resume Next 'This file may be missing if the personal OD
            webRoot = cliPolColl("ClientPolicy.ini")("DavUrlNamespace") 'account
            On Error GoTo 0                  'was logged out of the OneDrive app
            If locRoot = "" Or webRoot = "" Or cid = "" Then GoTo NextFolder
            locToWebColl.Add VBA.Array(locRoot, webRoot & "/" & cid, email, _
                                       syncID, syncFind, dirName), Key:=locRoot
            If Dir(vDir & "GroupFolders.ini") = "" Then GoTo NextFolder
            'Read GroupFolders.ini file
            cid = vbNullString: fileNum = FreeFile()
            Open vDir & "GroupFolders.ini" For Binary Access Read As #fileNum
                ReDim b(0 To LOF(fileNum)): Get fileNum, , b
            Close #fileNum: fileNum = 0
            #If Mac Then 'On Mac, the OneDrive settings files use UTF-8 encoding
                sUtf8 = b: GoSub DecodeUTF8
                b = sUtf16
            #End If 'Two lines per synced folder from other peoples personal ODs
            For Each line In Split(b, vbNewLine)
                If line Like "*_BaseUri = *" And cid = vbNullString Then
                    cid = LCase$(Mid$(line, InStrRev(line, "/", , 0) + 1, _
                       InStrRev(line, "!", , 0) - InStrRev(line, "/", , 0) - 1))
                    folderID = Left$(line, InStr(1, line, "_", 0) - 1)
                ElseIf cid <> vbNullString Then
                    locToWebColl.Add VBA.Array(locRoot & ps & odFolders( _
                                     folderID)(1), webRoot & "/" & cid & "/" & _
                                     Mid$(line, Len(folderID) + 9), email, _
                                     syncID, syncFind, dirName), _
                                Key:=locRoot & ps & odFolders(folderID)(1)
                    cid = vbNullString: folderID = vbNullString
                End If
            Next line
        End If
NextFolder:
        cid = vbNullString: s = vbNullString: email = vbNullString
    Next vDir

    'Clean the finished "dictionary" up, remove trailing "\" and "/"
    Dim tmpColl As Collection: Set tmpColl = New Collection
    For Each vItem In locToWebColl
        locRoot = vItem(0): webRoot = vItem(1): syncFind = vItem(4)
        If Right$(webRoot, 1) = "/" Then _
            webRoot = Left$(webRoot, Len(webRoot) - 1)
        If Right$(locRoot, 1) = ps Then _
            locRoot = Left$(locRoot, Len(locRoot) - 1)
        If Right$(syncFind, 1) = ps Then _
            syncFind = Left$(syncFind, Len(syncFind) - 1)
        tmpColl.Add VBA.Array(locRoot, webRoot, vItem(2), _
                              vItem(3), syncFind), locRoot
    Next vItem
    Set locToWebColl = tmpColl

    #If Mac Then 'deal with syncIDs
        If cloudStoragePathExists Then
            Set tmpColl = New Collection
            For Each vItem In locToWebColl
                locRoot = vItem(0): syncID = vItem(3): syncFind = vItem(4)
                locRoot = Replace(locRoot, syncFind, _
                                           syncIDtoSyncDir(syncID)(1), , 1)
                tmpColl.Add VBA.Array(locRoot, vItem(1), vItem(2)), locRoot
            Next vItem
            Set locToWebColl = tmpColl
        End If
    #End If

    GetWebPath = GetWebPath(path, False): Exit Function
    Exit Function

DecodeUTF8: 'UTF-8 must be transcoded to UTF-16 manually in VBA
    Const raiseErrors As Boolean = False 'Raise error if invalid UTF-8 is found?
    Dim o As Long, p As Long, q As Long
    Static numBytesOfCodePoints(0 To 255) As Byte
    Static mask(2 To 4) As Long
    Static minCp(2 To 4) As Long

    If numBytesOfCodePoints(0) = 0 Then
        For o = &H0& To &H7F&: numBytesOfCodePoints(o) = 1: Next o '0xxxxxxx
        '110xxxxx - C0 and C1 are invalid (overlong encoding)
        For o = &HC2& To &HDF&: numBytesOfCodePoints(o) = 2: Next o
        For o = &HE0& To &HEF&: numBytesOfCodePoints(o) = 3: Next o '1110xxxx
       '11110xxx - 11110100, 11110101+ (= &HF5+) outside of valid Unicode range
        For o = &HF0& To &HF4&: numBytesOfCodePoints(o) = 4: Next o
        For o = 2 To 4: mask(o) = (2 ^ (7 - o) - 1): Next o
        minCp(2) = &H80&: minCp(3) = &H800&: minCp(4) = &H10000
    End If
    Dim currByte As Byte
    utf8 = sUtf8
    ReDim utf16(0 To (UBound(utf8) - LBound(utf8) + 1) * 2)
    p = 0
    o = LBound(utf8)
    Do While o <= UBound(utf8)
        codepoint = utf8(o)
        numBytesOfCodePoint = numBytesOfCodePoints(codepoint)
        If numBytesOfCodePoint = 0 Then
            If raiseErrors Then Err.Raise 5
            GoTo insertErrChar
        ElseIf numBytesOfCodePoint = 1 Then
            utf16(p) = codepoint
            p = p + 2
        ElseIf o + numBytesOfCodePoint - 1 > UBound(utf8) Then
            If raiseErrors Then Err.Raise 5
            GoTo insertErrChar
        Else
            codepoint = utf8(o) And mask(numBytesOfCodePoint)
            For q = 1 To numBytesOfCodePoint - 1
                currByte = utf8(o + q)
                If (currByte And &HC0&) = &H80& Then
                    codepoint = (codepoint * &H40&) + (currByte And &H3F)
                Else
                    If raiseErrors Then _
                        Err.Raise 5
                    GoTo insertErrChar
                End If
            Next q
            'Convert the Unicode codepoint to UTF-16LE bytes
            If codepoint < minCp(numBytesOfCodePoint) Then
                If raiseErrors Then Err.Raise 5
                GoTo insertErrChar
            ElseIf codepoint < &HD800& Then
                utf16(p) = CByte(codepoint And &HFF&)
                utf16(p + 1) = CByte(codepoint \ &H100&)
                p = p + 2
            ElseIf codepoint < &HE000& Then
                If raiseErrors Then Err.Raise 5
                GoTo insertErrChar
            ElseIf codepoint < &H10000 Then
                If codepoint = &HFEFF& Then GoTo nextCp '(BOM - will be ignored)
                utf16(p) = codepoint And &HFF&
                utf16(p + 1) = codepoint \ &H100&
                p = p + 2
            ElseIf codepoint < &H110000 Then 'Calculate surrogate pair
                m = codepoint - &H10000
                Dim loSurrogate As Long: loSurrogate = &HDC00& Or (m And &H3FF)
                Dim hiSurrogate As Long: hiSurrogate = &HD800& Or (m \ &H400&)
                utf16(p) = hiSurrogate And &HFF&
                utf16(p + 1) = hiSurrogate \ &H100&
                utf16(p + 2) = loSurrogate And &HFF&
                utf16(p + 3) = loSurrogate \ &H100&
                p = p + 4
            Else
                If raiseErrors Then Err.Raise 5
insertErrChar:  utf16(p) = &HFD
                utf16(p + 1) = &HFF
                p = p + 2
                If numBytesOfCodePoint = 0 Then numBytesOfCodePoint = 1
            End If
        End If
nextCp: o = o + numBytesOfCodePoint 'Move to the next UTF-8 codepoint
    Loop
    sUtf16 = MidB$(utf16, 1, p)
    Return

DecodeANSI: 'Code for decoding ANSI string manually:
    ansi = sAnsi
    p = UBound(ansi) - LBound(ansi) + 1
    If p > 0 Then
        ReDim utf16(0 To p * 2 - 1): q = 0
        For p = LBound(ansi) To UBound(ansi)
            utf16(q) = ansi(p): q = q + 2
        Next p
        sUtf16 = utf16
    Else
        sUtf16 = vbNullString
    End If
    Return
End Function

Thanks for your work.

Any chance you could rewrite this as "proper" VBA, with End If statements and without colons and underscores everywhere? It might save a couple of lines, but makes the code hard to read and error-prone.

Hi @JefUtb, thanks for the comment!

You are right that the coding style I follow here is dubious and in many places I overdid it with the line continuations etc...

The reason I implemented it like this and why I sometimes adopt such a style in VBA is, that the Microsoft Office VBA IDE makes it very annoying to navigate larger projects.
Therefore, I like to write utility functions without any dependencies. I can put them all into one module and just copy-paste the ones I need into one module again, avoiding too many "library" modules that clutter the IDE.

Now the thing is, to actually rewrite this in a more readable way the most important change would be splitting it up into multiple procedures/functions, which I'm not too excited to do for the reasons I just explained. Many of the procedures I'd split this up into would have no other use than for this function (and maybe for GetLocalPath), so in my projects, I would have to always copy a bunch of interdependent functions or an entire library module, both of which I don't like.

I have spent a lot of time with this code and find it actually quite readable, stretching it out over more lines would make this function harder to navigate for me. Often when using line continuation, I try to shorten a block of code for which I know what it does and use multiple times (usually something to outsource into a different procedure), e.g.:

On Error Resume Next: cliPolColl fileName: keyExists = _
(Err.Number = 0): On Error GoTo -1: On Error GoTo 0

This just checks if a key already exists in a collection. I used to use Scripting.Dictionary instead but had to drop it for Mac compatibility.

fileNum = FreeFile
Open wDir & cid & ".dat" For Binary Access Read As #fileNum
    ReDim b(0 To LOF(fileNum)): Get fileNum, , b: s = b: size = LenB(s)
Close #fileNum: fileNum = 0

This just reads a file into the variable b as a byte array.

I use _ because I strictly adhere to an 80-character line-length limit in this code. This enables multiple editor windows side by side without horizontal scrolling. This enhances readability in my opinion.

I sometimes avoid End If by using

If condition Then _
    statement

to save a line. In my opinion, readability doesn't suffer because the block is still clearly indicated through indentation. Of course, it takes some getting used to it.

TL;DR:
This is supposed to be a copy-paste and everything-just-works-without-any-dependencies solution.

The friend I collaborated with on this solution implemented it independently in a library module and in a more conventional manner. The solution approach is the same but you may find it easier to read: link

The only difference is that he didn't implement Mac compatibility yet.

Hi, i use your awesome function and encountered an issue a few days ago that it doesn't give me the converted path anymore. but instead the https url.
What has happened, and how do i solve this :)
i use this one on stack overflow i might add.
https://stackoverflow.com/questions/77514627/save-email-attachment-to-sharepoint-onedrive/77517760?noredirect=1#comment136664713_77517760
In the top post where i explain my issue.

Hi @Bowman99, just to clarify: You have an HTTPS URL and you want to convert it to a local path? Then you are commenting under the wrong gist. 😊
Please try updating your function to the latest version which you can find here: https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d

If you still have the same issue afterwards let me know!

Hi buddy! Thanks for answering, yes you are right!
I'll try to update to the new code and ill get back to you.
Cheers!

Oh my god i love you :) It worked to update the code. I should’ve seen that explanation in the code sorry. I’ll look better next time!
Thank you so much for this, and your code over all guwidoe!

Hi @guwidoe,

I have run into a similar error that was found on GetLocalOneDrivePath.bas.vb

The debugger is shooting up error 457, “This key is already associated with an element of this collection”, at line 1164:
locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
mainSyncID, mainSyncFind, dirName), locRoot

This has since been fixed but has the same bug been applied here?

Appreciate the help!

Hi @guwidoe,

I have run into a similar error that was found on GetLocalOneDrivePath.bas.vb

The debugger is shooting up error 457, “This key is already associated with an element of this collection”, at line 1164: locToWebColl.Add VBA.Array(locRoot, webRoot, email, _ mainSyncID, mainSyncFind, dirName), locRoot

This has since been fixed but has the same bug been applied here?

Appreciate the help!

Have you tried the last version?

yes, currently running the latest Updated: 2023/10/02

Hi @BlakeR94, thanks for the notice... You are right, not all bugfixes are implemented here. I will update the function today and let you know once its done!

Awesome, Thank you!

@BlakeR94, I have now updated the function, sorry for the delay!

Working perfectly, thank you!

Hi @guwidoe,

I am encountering the same error as BlakeR94: "Run-Time error '457': The key is already associated with an element of this collection."

It's on line 5530 of my code...

5530 locToWebColl.Add VBA.Array(locRoot, webRoot & "/" & cid, email, _ syncID, syncFind, dirName), Key:=locRoot

Not entirely sure why this would error here?

Thanks!
Tom

Hi @monitom and sorry for the late reply.
There seem to have been some OneDrive updates and I'll have to update this function accordingly.
Can you check if the GetRemotePath function from the current version of LibFileTools works on your machine?

Hi @monitom and sorry for the late reply. There seem to have been some OneDrive updates and I'll have to update this function accordingly. Can you check if the GetRemotePath function from the current version of LibFileTools works on your machine?

Hi @guwidoe - No worries at all. Thanks for your reply.

GetRemotePath in LibFileTools worked correctly for my purposes.