Skip to content

Instantly share code, notes, and snippets.

@guwidoe

guwidoe/GetLocalOneDrivePath.bas.vb

Last active October 1, 2024 12:51
Show Gist options
  • Save guwidoe/038398b6be1b16c458365716a921814d to your computer and use it in GitHub Desktop.
Save guwidoe/038398b6be1b16c458365716a921814d to your computer and use it in GitHub Desktop.
Download ZIP
VBA Function to get the local path of a OneDrive/SharePoint synchronized Microsoft Office file
Raw
GetLocalOneDrivePath.bas.vb
'Attribute VB_Name = "GetLocalOneDrivePath"
'
' Cross-platform VBA Function to get the local path of OneDrive/SharePoint
' synchronized Microsoft Office files (Works on Windows and on macOS)
'
' Author: Guido Witt-Dörring
' Created: 2022/07/01
' Updated: 2024/10/01
' License: MIT
'
' ----------------------------------------------------------------
' https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
' https://stackoverflow.com/a/73577057/12287457
' ----------------------------------------------------------------
'
' 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:
' 1) Background and Alternative
' This function was intended to be written as a single procedure without any
' dependencies, for maximum portability between projects, as it implements a
' functionality that is very commonly needed for many VBA applications
' working inside OneDrive/SharePoint synchronized directories. I followed
' this paradigm because it was not clear to me how complicated this simple
' sounding endeavour would turn out to be.
' Unfortunately, more and more complications arose, and little by little,
' the procedure turned incredibly complex. I do not condone the coding
' style applied here, and this is not how I usually write code.
' Nevertheless, I'm not open to rewriting this code in a different style,
' because a clean implementation of this algorithm already exists, as pointed
' out in the following.
'
' If you would like to understand the underlying algorithm of how the local
' path can be found with only the Url-path as input, I recommend following
' the much cleaner implementation by Cristian Buse:
' https://github.com/cristianbuse/VBA-FileTools
' We developed the algorithm together and wrote separate implementations
' concurrently. His solution is contained inside a module-level library,
' split into many procedures and using features like private types and API-
' functions, that are not available when trying to create a single procedure
' without dependencies like below. This makes his code more readable.
'
' Both of our solutions are well tested and actively supported with bugfixes
' and improvements, so both should be equally valid choices for use in your
' project. The differences in performance/features are marginal and they can
' often be used interchangeably. If you need more file-system interaction
' functionality, use Cristians library, and if you only need GetLocalPath,
' just copy this function to any module in your project and it will work.
'
' 2) How does this function work?
' This function builds the URL to Local translation dictionary by extracting
' the mount points and the corresponding OneDrive URL-roots from the OneDrive
' settings files.
'
' For example, for your personal OneDrive, such a local mount point could
' look like this:
' - C:\Users\Username\OneDrive
'
' and the corresponding URL-root could look like this:
' - https://d.docs.live.net/f9d8c1184686d493
'
' This "dictionary" can then be used to "translate" a given OneDrive URL to a
' local path by replacing the part that is equal to one of the elements of
' the dictionary with the corresponding local mount point.
' For example, this OneDrive URL:
' - https://d.docs.live.net/f9d8c1184686d493/Folder/File.xlsm
' will be correctly "translated" to
' - C:\Users\Username\OneDrive\Folder\File.xlsm
'
' Because all possible OneDrive URLs for the local machine can be translated
' by the same dictionary, it is implemented as `Static` in this function.
' This means it will only be written the first time the function is called,
' all subsequent function calls will find the "dictionary" already
' initialized leading to shorter run time.
'
' In order to build the dictionary, the function reads files from...
' On Windows:
' - the "%LOCALAPPDATA%\Microsoft" directory
' On Mac:
' - the "~/Library/Containers/com.microsoft.OneDrive-mac/Data/" & _
' "Library/Application Support" directory
' - and/or the "~/Library/Application Support" directory
' It reads the following files:
' - \OneDrive\settings\Personal\ClientPolicy.ini
' - \OneDrive\settings\Personal\????????????????.dat
' - \OneDrive\settings\Personal\????????????????.ini
' - \OneDrive\settings\Personal\global.ini
' - \OneDrive\settings\Personal\GroupFolders.ini
' - \OneDrive\settings\Personal\SyncEngineDatabase.db *if .dat unavailable
' - \OneDrive\settings\Business#\????????-????-????-????-????????????.dat
' - \OneDrive\settings\Business#\????????-????-????-????-????????????.ini
' - \OneDrive\settings\Business#\ClientPolicy*.ini
' - \OneDrive\settings\Business#\global.ini
' - \OneDrive\settings\Business#\SyncEngineDatabase.db *if .dat unavailable
' - \Office\CLP\* (just the filename)
'
' Where:
' - "*" ... 0 or more characters
' - "?" ... one character [0-9, a-f]
' - "#" ... one digit
' - "\" ... path separator, (= "/" on MacOS)
' - The "???..." filenames represent CIDs)
'
' All of the `.ini` files can be read easily as they use UTF-16 encoding
' (UTF-8 on Mac, which makes it more difficult already).
' The `.dat` files are much more difficult to decipher, because they use a
' proprietary binary format. Luckily, the information we need can be
' extracted by looking for certain byte-patterns inside these files and
' copying and converting the data at a certain offset from these
' "signature" bytes.
'
' The `.db` files are the most challenging of them all and will only be read
' if the `.dat` files are not available.
' (for OneDrive version 23.184.0903.0001 and newer)
' They are SQLite files, which makes reading them with VBA in a reliable
' cross-platform way particularly challenging.
'
' For those who are interested in the exact algorithm behind how these files
' can be used to find the local path for a given OneDrive URL, please refer
' to the GitHub issues we used to discuss the progress on our solutions.
' Those are the following:
' - https://github.com/cristianbuse/VBA-FileTools/issues/1
' - https://github.com/cristianbuse/VBA-FileTools/issues/2
' - https://github.com/cristianbuse/VBA-FileTools/issues/17
'
' The implementation for mac contains a bunch of peculiarities that are not
' discussed in those issues. In order to understand exactly how the algorithm
' works, as mentioned earlier, it's best to read Cristians implementation:
' - https://github.com/cristianbuse/VBA-FileTools
'
'
' 3) How does this function NOT work?
' There are a plethora of solutions for this problem circulating online.
' A list of most of these solution can be found here:
' - https://stackoverflow.com/a/73577057/12287457
' In the stackoverflow post, detailed testing data is presented for all of
' the mentioned solutions and it can be observed, that, unfortunately,
' most of these alternatives are not very reliable.
' Most are using one of two approaches:
' 1. they use the environment variables set by OneDrive:
' - Environ(OneDrive)
' - Environ(OneDriveCommercial)
' - Environ(OneDriveConsumer)
' and replace part of the URL with it. There are many problems with this
' approach:
' 1. They are not being set by OneDrive on MacOS.
' 2. It is unclear exactly which part of the URL needs to be replaced.
' 3. Environment variables can be changed by the user.
' 4. Only there three exist. If more onedrive accounts are logged in,
' they just overwrite the previous ones.
' or,
' 2. they use the mount points OneDrive writes to the registry here:
' - \HKEY_CURRENT_USER\Software\SyncEngines\Providers\OneDrive\
' this also has several drawbacks:
' 1. The registry is not available on MacOS.
' 2. It's still unclear exactly what part of the URL should be replaced.
' 3. These registry keys can contain mistakes, like for example, when:
' - Synchronizing a folder called "Personal" from someone else's
' personal OneDrive
' - Synchronizing a folder called "Business1" from someone else's
' personal OneDrive and then relogging your own first Business
' OneDrive account
' - Relogging you 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
'
' For these reasons, this solution uses a completely different approach to
' solve this problem.
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' COMMENTS REGARDING THE USAGE:
' This function can be used as a User Defined Function (UDF) from the worksheet.
' (More on that, see "USAGE EXAMPLES")
'
' This function offers three optional parameters to the user, however using
' these should only be necessary in extremely rare situations.
' The best rule regarding their usage: Don't use them.
'
' In the following these parameters will still be explained.
'
'1) returnAll
' In some exceptional cases it is possible to map one OneDrive WebPath to
' multiple different localPaths. This can happen when multiple Business
' OneDrive accounts are logged in on one device, and multiple of these have
' access to the same OneDrive folder and they both decide to synchronize it or
' add it as link to their MySite library.
' Calling the function with returnAll:=True will return all valid localPaths
' for the given WebPath, separated by two forward slashes (//). This should be
' used with caution, as the return value of the function alone is, should
' multiple local paths exist for the input webPath, not a valid local path
' anymore.
' An example of how to obtain all of the local paths could look like this:
' Dim localPath as String, localPaths() as String
' localPath = GetLocalPath(webPath, True)
' If Not localPath Like "http*" Then
' localPaths = Split(localPath, "//")
' End If
'
'2) preferredMountPointOwner
' This parameter deals with the same problem as 'returnAll'
' If the function gets called with returnAll:=False (default), and multiple
' localPaths exist for the given WebPath, the function will just return any
' one of them, as usually, it shouldn't make a difference, because the result
' directories at both of these localPaths are mirrored versions of the same
' webPath. Nevertheless, this option lets the user choose, which mountPoint
' should be chosen if multiple localPaths are available. Each localPath is
' 'owned' by an OneDrive Account. If a WebPath is synchronized twice, this can
' only happen by synchronizing it with two different accounts, because
' OneDrive prevents you from synchronizing the same folder twice on a single
' account. Therefore, each of the different localPaths for a given WebPath
' has a unique 'owner'. preferredMountPointOwner lets the user select the
' localPath by specifying the account the localPath should be owned by.
' This is done by passing the Email address of the desired account as
' preferredMountPointOwner.
' For example, you have two different Business OneDrive accounts logged in,
' [email protected] and [email protected]
' Both synchronize the WebPath:
' webPath = "https://business1.sharepoint.com/sites/TestLib/Documents/" & _
"Test/Test/Test/test.xlsm"
'
' The first one has added it as a link to his personal OneDrive, the local
' path looks like this:
' C:\Users\username\OneDrive - Business1\TestLinkParent\Test - TestLinkLib\...
' ...Test\test.xlsm
'
' The second one just synchronized it normally, the localPath looks like this:
' C:\Users\username\Business1\TestLinkLib - Test\Test\test.xlsm
'
' Calling GetLocalPath like this:
' GetLocalPath(webPath,,, "[email protected]") will return:
' C:\Users\username\OneDrive - Business1\TestLinkParent\Test - TestLinkLib\...
' ...Test\test.xlsm
'
' Calling it like this:
' GetLocalPath(webPath,,, "[email protected]") will return:
' C:\Users\username\Business1\TestLinkLib - Test\Test\test.xlsm
'
' And calling it like this:
' GetLocalPath(webPath,, True) will return:
' C:\Users\username\OneDrive - Business1\TestLinkParent\Test - TestLinkLib\...
' ...Test\test.xlsm//C:\Users\username\Business1\TestLinkLib - Test\Test\...
' ...test.xlsm
'
' Calling it normally like this:
' GetLocalPath(webPath) will return any one of the two localPaths, so:
' C:\Users\username\OneDrive - Business1\TestLinkParent\Test - TestLinkLib\...
' ...Test\test.xlsm
' OR
' C:\Users\username\Business1\TestLinkLib - Test\Test\test.xlsm
'
' If `preferredMountPointOwner` does not work on Mac, the following might
' explain a reason and a workaround:
'
' In order to correlate the users email address with the OneDrive account
' CID, the function reads the filenames of the files located in the
' - %LOCALAPPDATA%\Microsoft\Office\CLP\
' directory.
'
' On MacOS, the \Office\CLP\* exists for each Microsoft Office application
' separately. Depending on whether the application was already used in
' active syncing with OneDrive it may contain different/incomplete files.
' In the code, the path of this directory is stored inside the variable
' 'clpPath'. On MacOS, the defined clpPath might not exist or not contain
' all necessary files for some host applications, because Environ("HOME")
' depends on the host app.
' This is not a big problem as the function will still work, however in
' this case, specifying a preferredMountPointOwner will do nothing.
' To make sure this directory and the necessary files exist, a file must
' have been actively synchronized with OneDrive by the application whose
' "HOME" folder is returned by Environ("HOME") while being logged in
' to that application with the account whose email is given as
' preferredMountPointOwner, at some point in the past!
'
' If you are usually working with Excel but are using this function in a
' different app, you can instead use an alternative (Excels CLP folder) as
' the clpPath as it will most likely contain all the necessary information
' The alternative clpPath is commented out in the code, if you prefer to
' use Excels CLP folder per default, just un-comment the respective line
' in the code.
'
'3) rebuildCache
' The function creates a "translation" dictionary from the OneDrive settings
' files and then uses this dictionary to "translate" WebPaths to LocalPaths.
' This dictionary is implemented as a static variable to the function doesn't
' have to recreate it every time it is called. It is written on the first
' function call and reused on all the subsequent calls, making them faster.
' If the function is called with rebuildCache:=True, this dictionary will be
' rewritten, even if it was already initialized.
' Note that it is not necessary to use this parameter manually, even if a new
' MountPoint was added to the OneDrive, or a new OneDrive account was logged
' in since the last function call because the function will automatically
' determine if any of those cases occurred, without sacrificing performance.
'-------------------------------------------------------------------------------
Option Explicit
''------------------------------------------------------------------------------
'' USAGE EXAMPLES:
'' Excel:
'Private Sub TestGetLocalPathExcel()
' Debug.Print GetLocalPath(ThisWorkbook.FullName)
' Debug.Print GetLocalPath(ThisWorkbook.path)
'End Sub
'
' Usage as User Defined Function (UDF):
' You might have to replace ; with , in the formulas depending on your settings.
' Add this formula to any cell, to get the local path of the workbook:
' =GetLocalPath(LEFT(CELL("filename";A1);FIND("[";CELL("filename";A1))-1))
'
' To get the local path including the filename (the FullName), use this formula:
' =GetLocalPath(LEFT(CELL("filename";A1);FIND("[";CELL("filename";A1))-1) &
' TEXTAFTER(TEXTBEFORE(CELL("filename";A1);"]");"["))
'
''Word:
'Private Sub TestGetLocalPathWord()
' Debug.Print GetLocalPath(ThisDocument.FullName)
' 'Debug.Print GetLocalPath(ThisDocument.Path) '<- Do NOT use this.
' 'Document.Path returns an URL encoded url, e.g. " " -> "%20", therefore
' 'GetLocalPath doesn't work if there are encoded characters in the part
' 'that is supposed to be replaced. Document.FullName doesn't have this
' 'issue. Therefore, instead of GetLocalPath(ThisDocument.Path), use
' 'something like:
' Dim docLocalPath As String: docLocalPath = ThisDocument.path
' If docLocalPath Like "http*" Then
' docLocalPath = GetLocalPath(Left(ThisDocument.FullName, _
' InStrRev(ThisDocument.FullName, "/") - 1))
' End If
' Debug.Print docLocalPath
'End Sub
'
''PowerPoint:
'Private Sub TestGetLocalPathPowerPoint()
' Debug.Print GetLocalPath(ActivePresentation.FullName)
' Debug.Print GetLocalPath(ActivePresentation.path)
'End Sub
''------------------------------------------------------------------------------
'This Function will convert a OneDrive/SharePoint Url path, e.g. Url containing
'https://d.docs.live.net/; .sharepoint.com/sites; my.sharepoint.com/personal/...
'to the locally synchronized path on your current pc or mac, e.g. a path like
'C:\users\username\OneDrive\ on Windows; or /Users/username/OneDrive/ on MacOS,
'if you have the remote directory locally synchronized with the OneDrive app.
'If no local path can be found, the input value will be returned unmodified.
'Author: Guido Witt-Dörring
'Source: https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
' https://stackoverflow.com/a/73577057/12287457
Public Function GetLocalPath(ByVal path As String, _
Optional ByVal returnAll As Boolean = False, _
Optional ByVal preferredMountPointOwner As String = "", _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
Const vbErrPermissionDenied As Long = 70
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 = "GetLocalPath"
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 Not Left$(path, 8) = "https://" Then GetLocalPath = path: Exit Function
Dim webRoot As String, locRoot As String, s As String, vItem As Variant
Dim pmpo As String: pmpo = LCase$(preferredMountPointOwner)
If Not locToWebColl Is Nothing And Not rebuildCache Then
Dim resColl As Collection: Set resColl = New Collection
'If the locToWebColl is initialized, this logic will find the local path
For Each vItem In locToWebColl
locRoot = vItem(0): webRoot = vItem(1)
If InStr(1, path, webRoot, vbTextCompare) = 1 Then _
resColl.Add key:=vItem(2), _
item:=Replace(Replace(path, webRoot, locRoot, , 1), "/", ps)
Next vItem
If resColl.Count > 0 Then
If returnAll Then
For Each vItem In resColl: s = s & "//" & vItem: Next vItem
GetLocalPath = Mid$(s, 3): Exit Function
End If
On Error Resume Next: GetLocalPath = resColl(pmpo): On Error GoTo 0
If GetLocalPath <> "" Then Exit Function
GetLocalPath = resColl(1): Exit Function
End If
'Local path was not found with cached mountpoints
GetLocalPath = path 'No Exit Function here! Check if cache needs rebuild
End If
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, keyExists As Boolean
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
'
Const chunkSize As Long = &H100000 '1MB
Const minName As Long = 15
Const maxSigByte As Byte = 9
Const maxHeader As Long = 21
Const minIDSize As Long = 12
Const maxIDSize As Long = 48
Const minThreeIDSizes As Long = minIDSize * 3
Const maxThreeIDSizes As Long = maxIDSize * 3
Const leadingBuff As Long = maxHeader + maxThreeIDSizes
Const headBytesOffset As Long = 15
Const bangCode As Long = 33 'Asc("!")
Dim curlyStart As String: curlyStart = ChrW$(&H7B22) '"{
Dim quoteB As String: quoteB = ChrB$(&H22) '"
Dim bangB As String: bangB = ChrB$(bangCode) '!
Dim sig As String
Dim idPatternDB As String
Dim isPersonal As Boolean: isPersonal = (dirName = "Personal")
Dim nameStart As Long
Dim nameEnd As Long
Dim lastRecord As Long
Dim lastFolderID As String
Dim idSize(1 To 4) As Long
Dim nameSize As Long
Dim mustAdd As Boolean
Dim arr() As Variant
Dim isASCII As Boolean
Dim tempID As String
idPatternDB = Replace(Space$(12), " ", "[a-fA-F0-9]")
If isPersonal Then
sig = bangB
idPatternDB = "*" & idPatternDB & "![a-fA-F0-9]*"
Else
sig = curlyStart
idPatternDB = idPatternDB & "*"
End If
lastFileUpdate = 0
ReDim b(1 To chunkSize)
Dim t As Single: t = Timer
Do
If Timer - t > 0.1! Then
DoEvents
t = Timer
End If
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
End If
Get fileNum, lastRecord, b
s = b
i = InStrB(1, s, sig)
Do While i > 0
If isPersonal Then
For j = i - 1 To i - maxIDSize Step -1
If j = 0 Then GoTo NextSig
If b(j) < bangCode Then Exit For
Next j
If (j < maxHeader) Or (i - j < minIDSize) Then GoTo NextSig
Else
j = InStrB(i + 2, s, quoteB)
If j = 0 Then Exit Do 'Next chunk
idSize(4) = j - i + 1
If idSize(4) > maxIDSize Then GoTo NextSig
For j = i - 1 To i - maxThreeIDSizes Step -1
If j = 0 Then GoTo NextSig
If b(j) < bangCode Then Exit For
Next j
If j < maxHeader Then GoTo NextSig
idSize(1) = i - j - 1 'ID 1+2+3
If idSize(1) < minThreeIDSizes Then GoTo NextSig
End If
k = j + 1 'ID1 Start
For j = j To j - headBytesOffset + 1 Step -1
If b(j) > maxSigByte Then GoTo NextSig
Next j
If (b(j) <= maxSigByte) And (b(j - 1) < &H80) Then j = j - 1
If b(j) < minName Then j = j - 1
nameSize = b(j)
If nameSize Mod 2 = 0 Then GoTo NextSig
nameSize = (nameSize - 13) / 2
If b(j - 1) > &H7F Then
nameSize = (b(j - 1) - &H80) * &H40 + nameSize
j = j - 1
End If
If j < 5 Then GoTo NextSig
If (nameSize < 1) Or (b(j - 4) = 0) Then GoTo NextSig
If isPersonal Then
idSize(4) = (b(j - 1) - 13) / 2
idSize(3) = (b(j - 2) - 13) / 2
idSize(2) = (b(j - 3) - 13) / 2
idSize(1) = (b(j - 4) - 13) / 2
nameStart = k + idSize(1) + idSize(2) + idSize(3) + idSize(4)
Else
If b(j - 1) <> idSize(4) * 2 + 13 Then GoTo NextSig
idSize(3) = (b(j - 2) - 13) / 2
idSize(2) = (b(j - 3) - 13) / 2
idSize(1) = idSize(1) - idSize(2) - idSize(3)
nameStart = i + idSize(4)
End If
For j = 1 To 4
If (idSize(j) < minIDSize) _
Or (idSize(j) > maxIDSize) Then GoTo NextSig
Next j
nameEnd = nameStart + nameSize - 1
If nameEnd > chunkSize Then Exit Do 'Next chunk
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = MidB$(s, k, idSize(1)) 'Decode ANSI string manually:
GoSub DecodeANSI: folderID = sUtf16
#Else 'Windows
folderID = StrConv(MidB$(s, k, idSize(1)), vbUnicode)
#End If
If Not folderID Like idPatternDB Then GoTo NextSig
k = k + idSize(1)
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = MidB$(s, k, idSize(2)) 'Decode ANSI string manually:
GoSub DecodeANSI: parentID = sUtf16
#Else 'Windows
parentID = StrConv(MidB$(s, k, idSize(2)), vbUnicode)
#End If
If Not parentID Like idPatternDB Then GoTo NextSig
If isPersonal Then
k = k + idSize(2)
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = MidB$(s, k, idSize(3)) 'Decode ANSI string manually:
GoSub DecodeANSI: tempID = sUtf16
#Else 'Windows
tempID = StrConv(MidB$(s, k, idSize(3)), vbUnicode)
#End If
If Not tempID Like idPatternDB Then GoTo NextSig
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = MidB$(s, k + idSize(3), idSize(4)) 'Decode ANSI string manually:
GoSub DecodeANSI: tempID = sUtf16
#Else 'Windows
tempID = StrConv(MidB$(s, k + idSize(3), idSize(4)), vbUnicode)
#End If
If Not tempID Like idPatternDB Then GoTo NextSig
End If
On Error Resume Next
odFolders folderID
mustAdd = (Err.Number <> 0)
On Error GoTo 0
If mustAdd Then
folderName = MidB$(s, nameStart, nameSize)
isASCII = True
For k = nameStart To nameEnd
If b(k) > &H7F Then
isASCII = False
Exit For
End If
Next k
If isASCII Then
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = folderName 'Decode ANSI string manually:
GoSub DecodeANSI: folderName = sUtf16
#Else 'Windows
folderName = StrConv(folderName, vbUnicode)
#End If
Else
sUtf8 = folderName: GoSub DecodeUTF8
folderName = sUtf16
End If
odFolders.Add VBA.Array(parentID, folderName, isASCII, folderID), folderID
Else
arr = odFolders(folderID)
If (Not arr(2)) Or (Len(arr(1)) < nameSize) Then
folderName = MidB$(s, nameStart, nameSize)
isASCII = True
For k = nameStart To nameEnd
If b(k) > &H7F Then
isASCII = False
Exit For
End If
Next k
If isASCII Then
#If Mac Then 'StrConv doesn't work reliably on Mac ->
sAnsi = folderName 'Decode ANSI string manually:
GoSub DecodeANSI: folderName = sUtf16
#Else 'Windows
folderName = StrConv(folderName, vbUnicode)
#End If
Else
sUtf8 = folderName: GoSub DecodeUTF8
folderName = sUtf16
End If
arr(1) = folderName
arr(2) = isASCII
odFolders.Remove folderID
odFolders.Add arr, folderID
End If
End If
i = nameEnd
NextSig:
i = InStrB(i + 1, s, sig)
Loop
If i = 0 Then
lastRecord = lastRecord + chunkSize - leadingBuff
ElseIf i > leadingBuff Then
lastRecord = lastRecord + i - leadingBuff
Else
lastRecord = lastRecord + i
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 = ""
ReDim parts(0 To 20)
Dim v As Variant
Dim c As Long: c = Len(line)
i = InStr(1, line, " ")
parts(0) = Left$(line, i - 1)
k = 0
Do
Do
i = i + 1
s = Mid$(line, i, 1)
Loop Until s <> " "
If i > c Then Exit Do
If s = """" Then
i = i + 1
j = InStr(i, line, """")
Else
j = InStr(i + 1, line, " ")
End If
If j = 0 Then j = c + 1
k = k + 1
If k > UBound(parts) Then ReDim Preserve parts(0 To k)
parts(k) = Mid$(line, i, j - i)
i = j
Loop Until j > c
ReDim Preserve parts(0 To k)
Select Case parts(0) '(tag)
Case "libraryScope" 'One line per synchronized library
locRoot = parts(14)
syncFind = locRoot: syncID = parts(16)
libNr = parts(2)
siteID = parts(10): webID = parts(11): libID = parts(12)
If parts(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 = parts(3)
locRoot = parts(6): syncFind = locRoot
syncID = parts(9)
s = vbNullString: parentID = parts(4)
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(11): If relPath = " " Then relPath = "" 'lib
siteID = parts(7)
webID = parts(8): libID = parts(9): lnkID = parts(10)
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$(parts(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
ElseIf line Like "libraryScope = *" Then
parts = Split(line, """"): locRoot = parts(9)
syncFind = locRoot: syncID = parts(7)
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
GetLocalPath = GetLocalPath(path, returnAll, pmpo, 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
Raw
TestTable.md
Nr. Test description WebPath LocalPath1 LocalPath2
1 Personal OneDrive, normal file inside first level folder https://d.docs.live.net/f9d8c1184686d493/Testfolder_toplvl/test.xlsm C:\Users\UN\OneDrive\Testfolder_toplvl\test.xlsm
2 Personal OneDrive, normal file inside fourth level folder https://d.docs.live.net/f9d8c1184686d493/The X Company/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive\The X Company\Test\Test\Test\test.xlsm
3 Personal OneDrive, normal file in top level folder (root directory) https://d.docs.live.net/f9d8c1184686d493/test.xlsm C:\Users\UN\OneDrive\test.xlsm
4 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 1st level, folder named "Personal" because of confusion in the registry https://d.docs.live.net/35f3889de6a905a8/Personal/test.xlsm C:\Users\UN\OneDrive\Personal\test.xlsm
5 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 1st level, folder named "Business1" because of cunfusion in the registry https://d.docs.live.net/35f3889de6a905a8/Business1/test.xlsm C:\Users\UN\OneDrive\Business1\test.xlsm
6 Personal OneDrive, folder shared by other personal account 1, folder synchonized at 2nd level https://d.docs.live.net/56aedc5c5f2afc2b/FirstLevel/SecondLevel/test.xlsm C:\Users\UN\OneDrive\SecondLevel\test.xlsm
7 Personal OneDrive, folder shared by other personal account 1, folder synchonized at 2nd level with tricky name https://d.docs.live.net/56aedc5c5f2afc2b/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive\Test\Test\test.xlsm
8 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 4th level with tricky name https://d.docs.live.net/35f3889de6a905a8/Test (1)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm C:\Users\UN\OneDrive\FourthLevel\Test (1)\Test\test.xlsm
9 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 3th level with tricky name https://d.docs.live.net/35f3889de6a905a8/Test/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive\Test (1)\Test\test.xlsm
10 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 3rd level with tricky name https://d.docs.live.net/35f3889de6a905a8/Test (2)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm C:\Users\UN\OneDrive\Test (1) (1)\FourthLevel\Test (1)\Test\test.xlsm
11 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 3rd level with tricky name https://d.docs.live.net/35f3889de6a905a8/Test (3)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm C:\Users\UN\OneDrive\Test (1) (2)\Test\test.xlsm
12 Personal OneDrive, folder shared by other personal account 2, folder synchonized at 3rd level with tricky name https://d.docs.live.net/35f3889de6a905a8/Test (4)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm C:\Users\UN\OneDrive\Test (1) (3)\Test\test.xlsm
13 Personal OneDrive, folder shared by other personal account 3, folder synchonized at 2nd level with tricky name https://d.docs.live.net/7aef338a1493aec9/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive\Test (2)\Test\test.xlsm
14 Personal OneDrive, folder shared by other personal account 4, folder synchonized at 2nd level https://d.docs.live.net/56aedc5c5f2afc2b/Test (1)/Test/Test/test.xlsm C:\Users\UN\OneDrive\Test (3)\Test\test.xlsm
15 Business OneDrive personal library https://org1-my.sharepoint.com/personal/person1_org1_com/Documents/-Test-/test.xlsm C:\Users\UN\OneDrive - org1\-Test-\test.xlsm
16 Business OneDrive personal library https://org1-my.sharepoint.com/personal/person1_org1_com/Documents/Test/Test/Test.xlsm C:\Users\UN\OneDrive - org1\Test\Test\Test.xlsm
17 Business OneDrive personal library https://org2-my.sharepoint.com/personal/person1_org2_com/Documents/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive - org2\Test\Test\Test\test.xlsm
18 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the root level to "personal" library https://org2.sharepoint.com/sites/TestLinkLib2/Shared Documents/test.xlsm C:\Users\UN\OneDrive - org2\Documents - TestLinkLib2\test.xlsm
19 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 3rd level to "personal" library, linked folder same name as other folder in personal OneDrive https://org2.sharepoint.com/sites/TestLib2/Shared Documents/TestOnlyAddedAsLink/Test/Test/test.xlsm C:\Users\UN\OneDrive - org2\Test - TestLinkLib\test.xlsm
20 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 1st level to "personal" library, link put inside other folder in personal OneDrive, now sits at second level https://org2.sharepoint.com/sites/TestLib2/Shared Documents/firstLevelFolder/test2.xlsm C:\Users\UN\OneDrive - org2\TestLinkParent\firstLevelFolder\test2.xlsm
21 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 7th level to "personal" library, link put inside other folder in personal OneDrive, now sits at fourth level https://org2.sharepoint.com/sites/TestLib2/Shared Documents/level1/level2/level3/level4/level5/level6/level7/test2.xlsm C:\Users\UN\OneDrive - org2\TestLinkParent\LinkParentLevel2\linkParentLevel3\level7\test2.xlsm
22 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 2nd level to ""personal"" library, link put inside other folder in personal OneDrive, now sits at fourth level, all folder names (web and local) contain crazy unicode characters designed to make stuff break https://organization2.sharepoint.com/sites/UnicodeSupportTest/Shared Documents/😀👩‍👩🦲👩👩‍👩‍👧‍👦🦲‍👩‍👧‍👦🦲‍👧‍👦UnicodeSupportTest𐀀😀‍👩👩‍👩‍👧‍👦💁🏼‍♀️🧔🏻‍♂️👩‍❤️‍👨🏃🏻‍♀️/😀👩‍👩🦲👩👩‍👩‍👧‍👦🦲‍👩‍👧‍👦🦲‍👧‍👦UnicodeSupportTest𐀀😀‍👩👩‍👩‍👧‍👦💁🏼‍♀️🧔🏻‍♂️👩‍❤️‍👨🏃🏻‍♀️/T/UnicodeTest_v1.xlsm C:\Users\username\OneDrive - Organization2\😀👩‍👩🦲👩👩‍👩‍👧‍👦🦲‍👩‍👧‍👦🦲‍👧‍👦Test𐀀😀‍👩👩‍👩‍👧‍👦💁🏼‍♀️🧔🏻‍♂️👩‍❤️‍👨🏃🏻‍♀️\😀👩‍👩🦲👩👩‍👩‍👧‍👦🦲‍👩‍👧‍👦🦲‍👧‍👦Test𐀀😀‍👩👩‍👩‍👧‍👦💁🏼‍♀️🧔🏻‍♂️👩‍❤️‍👨🏃🏻‍♀️\T\UnicodeTest_v1.xlsm
23 Business OneDrive shared personal library, folder shared from other Business account's personal library from the same company, folder synchonized at 1st level https://org1-my.sharepoint.com/personal/person3_org1_com/Documents/Shared Folder/Beispiel import.xlsm C:\Users\UN\org1\Person3 - Person1\Beispiel import.xlsm
24 Business OneDrive shared personal library, folder shared from other Business account's personal library from the same company, folder synchonized at 1st level, folder itself doesn't exist https://org1-my.sharepoint.com/personal/person3_org1_com/Documents/Shared Folder/Test/ C:\Users\UN\org1\Person3 - Person1\Test\
25 Business OneDrive shared personal library, folder shared from other Business account's personal library from the same company, folder synchonized at 3rd level https://org1-my.sharepoint.com/personal/person2_org1_com/Documents/Test/File/Test/3.xlsm C:\Users\UN\org1\Person2 - Test\3.xlsm
26 Business OneDrive shared (SharePoint/TeamSite) library, library synchonized at root level https://org1.sharepoint.com/sites/AI/Shared Documents/Test/test.xlsm C:\Users\UN\org1\AI - Dokumente\Test\test.xlsm
27 Business OneDrive shared (SharePoint/TeamSite) library, library synchonized at root level, file doesn't exist https://org1.sharepoint.com/sites/workspaces/project1as/Shared Documents/Test.xlsm C:\Users\UN\org1\project1 After Sales - Documents\Test.xlsm
28 Business OneDrive shared (SharePoint/TeamSite) library, library synchonized at root level, just path, no file https://org1.sharepoint.com/sites/workspaces/project1/Shared Documents/100_Business Development/ C:\Users\UN\org1\project1 - Documents\100_Business Development\
29 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 1st level https://org1.sharepoint.com/sites/project2/Shared Documents/General/2021/04_Working/- Archiv -/test.xlsm C:\Users\UN\org1\project2 - General\2021\04_Working\- Archiv -\test.xlsm
30 Business OneDrive shared (SharePoint/TeamSite) library, library called "MySite" for confustion with business "personal" library folder, library synchonized at root level https://org2.sharepoint.com/sites/MySite/Shared Documents/test.xlsm C:\Users\UN\org2\MySite - Documents\test.xlsm
31 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level, tricky folder names https://org2.sharepoint.com/sites/TestLib3rdLvlMount/Shared Documents/Test/Test/test.xlsm C:\Users\UN\org2\TestLib3rdLvlMount - Test\test.xlsm
32 Business OneDrive shared (SharePoint/TeamSite) library, library was renamed after creation, folder synchonized at 3rd level, tricky folder names https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test (1)/Test/Test/Test/test.xlsm C:\Users\UN\org2\ChangedName - Test\test.xlsm
33 Business OneDrive shared (SharePoint/TeamSite) library, library has space in its name, folder synchonized at 2nd level https://org2.sharepoint.com/sites/SpaceinName/Shared Documents/Test/Test/test.xlsm C:\Users\UN\org2\Space in Name - Test\test.xlsm
34 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level https://org2.sharepoint.com/sites/TestLib3rdLvlMount/Shared Documents/2ndLevel/3rdLevel/test.xlsm C:\Users\UN\org2\TestLib3rdLvlMount - 3rdLevel\test.xlsm
35 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 6th level, tricky folder names https://org2.sharepoint.com/sites/TestLib3rdLvlMount/Shared Documents/Test (1)/Test/Test/Test/Test/Test/Test/Test/Test/test.xlsm C:\Users\UN\org2\TestLib3rdLvlMount - Test (1)\Test\Test\test.xlsm
36 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 6th level https://org2.sharepoint.com/sites/TestLib3rdLvlMount/Shared Documents/Level1/Level2/Level3/Level4/Level5/Level6/test.xlsm C:\Users\UN\org2\TestLib3rdLvlMount - Level6\test.xlsm
37 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level, path target at 3rd level https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test (2)/Test/Test/test.xlsm C:\Users\UN\org2\ChangedNameAgain - Test\test.xlsm
38 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level, path target at 4th level, decoy files and folders that look identical at lower levels https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test (2)/Test/Test/Test/test.xlsm C:\Users\UN\org2\ChangedNameAgain - Test\Test\test.xlsm
39 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level, path target at 6th level, decoy files and folders that look identical at lower levels https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test (2)/Test/Test/Test/Test/Test/test.xlsm C:\Users\UN\org2\ChangedNameAgain - Test\Test\Test\Test\test.xlsm
40 Business OneDrive shared (SharePoint/TeamSite) library, folder synchonized at 3rd level, path target at 7th level, decoy files and folders that look identical at lower levels, non existent folder and file! https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test (2)/Test/Test/Test/Test/Test/Test/test.xlsm C:\Users\UN\org2\ChangedNameAgain - Test\Test\Test\Test\Test\test.xlsm
41 Business OneDrive shared (SharePoint/TeamSite) library, library was renamed after creation, folder synchonized at 2nd level by Business1, folder synchonized AGAIN at 2nd level by Business2! https://org2.sharepoint.com/sites/InitialName/Shared Documents/2ndLevel/3rdLevel/test.xlsm C:\Users\UN\org2\ChangedName - 3rdLevel\test.xlsm C:\Users\UN\org2\Team site - 3rdLevel\test.xlsm
42 Business OneDrive shared (SharePoint/TeamSite) library, library was renamed after creation, folder synchonized at 2nd level by Business1, folder synchonized AGAIN at 2nd level by Business2! https://org2.sharepoint.com/sites/InitialName/Shared Documents/Test/Test/test.xlsm C:\Users\UN\org2\ChangedName - Test (1)\test.xlsm C:\Users\UN\org2\Team site - Test\test.xlsm
43 Business OneDrive shared (SharePoint/TeamSite) library, library was renamed after creation, folder synchonized at 3rd level by Business1, folder synchonized AGAIN at 2nd level by Business2! https://org2.sharepoint.com/sites/TestLib22/Shared Documents/Test/Test/Test/Test/test.xlsm C:\Users\UN\org2\TestLib - Test (3)\Test\Test\test.xlsm C:\Users\UN\org2\TestLib - Test (2)\Test\test.xlsm
44 Business OneDrive shared (SharePoint/TeamSite) library, library was renamed after creation, folder synchonized at 3rd level by Business1, folder synchonized AGAIN at 5th level by Business2! https://org2.sharepoint.com/sites/TestLib3rdLvlMount/Shared Documents/TestMountAtTwoDifferentLevels/Test/Test/Test/Test/test.xlsm C:\Users\UN\org2\TestLib - Test\test.xlsm C:\Users\UN\org2\TestLib - Test (1)\Test\Test\test.xlsm
45 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 2nd level to "personal" library by Business2 AND ALSO mounted at 1st level by Business1 https://org2.sharepoint.com/sites/TestLib2/Shared Documents/Level2/Level3/test.xlsm C:\Users\UN\OneDrive - org2\Level3\test.xlsm C:\Users\UN\org2\TestLinkLib - Level2\Level3\test.xlsm
46 Business OneDrive shared (SharePoint/TeamSite) library, library added as Link at the 2nd level to "personal" library by Business2 (link moved into other folder inside "personal" library and now sitting at second level itself!), folder ALSO mounted at 2nd level by Business1 https://org2.sharepoint.com/sites/TestLib2/Shared Documents/Test/Test/Test/test.xlsm C:\Users\UN\OneDrive - org2\TestLinkParent\Test - TestLinkLib\Test\test.xlsm C:\Users\UN\org2\TestLinkLib - Test\Test\test.xlsm
@cristianbuse
Copy link

@Bowman99 ,

YES!!! It sorted it out, what happened?

I made some changes to the gist a week ago because Guido was too busy, and I basically did not think about the case where such infinite loop can happen. When Guido was back he trusted the changes I made and introduced the bug. Apologies to anyone affected!

@Bowman99
Copy link

Bowman99 commented Jul 8, 2024

Ok, cool, then a bug was sorted then?
Thanks!

@guwidoe
Copy link
Author

guwidoe commented Jul 8, 2024

Cristian made a crucial contribution to the most difficult part of this entire function last week. I did test the changes he made but the infinite loop problem didn't occur on my system during the testing and no anomaly was picked up.

I want to thank not only Cristian but also everyone rising these issues because without you we could have never come so far. For now it seems the bug was indeed fixed, thank you again @Bowman99!

@Bowman99
Copy link

Bowman99 commented Jul 8, 2024

Great to hear! Enjoy your summer if you are in that part of the world :)

@zhona9
Copy link

zhona9 commented Jul 18, 2024

Hi @zhona9 ,

I simply cannot replicate the issue. I used the data in both diagnostics files you've sent and they both work fine. In lack of other ideas I tought that maybe character 160 is the issue although I saw that it literally is at line break.

m_providers.arr(i) has an array item 1, yet it throws runtime error 1004 "Application-defined or object-defined error". This doesn't happen when I run the code at all. I think after that the path becomes an empty string.

This is super weird. It could be a compilation bug in VBA. What happens if you replace this:

        With m_providers.arr(i)
            If StrCompLeft(odWebPath, .webPath, vbTextCompare) = 0 Then
                collMatches.Add i
                If Not .isBusiness Then Exit For
                If .isMain Then mainIndex = .accountIndex
            End If
        End With

with this:

        If StrCompLeft(odWebPath, m_providers.arr(i).webPath, vbTextCompare) = 0 Then
            collMatches.Add i
            If Not m_providers.arr(i).isBusiness Then Exit For
            If m_providers.arr(i).isMain Then mainIndex = m_providers.arr(i).accountIndex
        End If

?

@cristianbuse the new code works! Thank you!

@itsdalien
Copy link

image

New version creating issues... Please help. Error 325

image

image
image

@itsdalien
Copy link

This from business1 Copied -ab560eeb-5750-4951-a137-1121f239521a.ini
No such file in business2

libraryScope = 0 fed6c2f80cb14e1586f0263a7d655229 5 "MySite" "ODB" 2 https://onbmd-my.sharepoint.com/personal/phimat1_bmd_com_au "9a2a4ae5-8ac1-460b-90f0-bb3c8516df35" b42eee33807147c89a83b41f505e3250 7708a546e18b4dbf9eb35dc2b78816f0 99ac8f9bb78e4e7c83f639427fc1ca07 0 "" 11 00000000-0000-0000-0000-000000000000 - 0 0 00000000-0000-0000-0000-000000000000
libraryScope = 64 ae03619de9cc47e4b01660d678a766c6+64 5 "Andrew Tait" "Documents" 3 https://onbmd-my.sharepoint.com/personal/andtai1_bmd_com_au "9a2a4ae5-8ac1-460b-90f0-bb3c8516df35" af063fb6573f43f9a5bdc7eed1776083 04b471ea7aa14d65a16b95d8b9414621 641e82b4131c462cba45bda212ed86a0 0 "" 11 00000000-0000-0000-0000-000000000000 - 0 0 00000000-0000-0000-0000-000000000000
libraryScope = 1 40b27423fbe744d78f6fb9585c97bbf2+1 5 "121-2116 MELROSE PARKEARLY EARTHWORKS" "Cost Planning and Forecasting" 4 https://onbmd.sharepoint.com/sites/121-2116_Project "9a2a4ae5-8ac1-460b-90f0-bb3c8516df35" 3cfe5036ba494e01a5bce24da4ddbbdb 2a6ec90471b749b2b04edd0412fa004f 793cd0868bad45978e4e478149615695 1727130440 "C:\Users\PHIMAT1\B.M.D. Holdings Pty. Limited\121-2116 MELROSE PARKEARLY EARTHWORKS - Cost Planning and Forecasting" 1 1c7930bc-c826-4a84-9bcd-da74115fd0c1 - 7599824371413183 1753638057 00000000-0000-0000-0000-000000000000
libraryFolder = 0 64 0cc7ce1ff42c45228e451a8efccfcd78+64 1722574322 "C:\Users\PHIMAT1\B.M.D. Holdings Pty. Limited\Andrew Tait - 121-2116 MELROSE PARK" 1 "121-2116 MELROSE PARK" 62a52a7a-3663-42fa-98bc-d4fd2344607f 31243722414945895 1753638057 00000000-0000-0000-0000-000000000000
AddedScope = 6 0fa45908a231450aafebd9a381627205 3 https://onbmd-my.sharepoint.com/personal/youbha1_bmd_com_au "0f6c1caf-e6bd-4b86-9946-3771ecd085d5" 6d46f662d94b417e942f4e13a216b547 ccff415979174e8e8b08660b2f63298c b53a0113fe9f49e6a1f8dd426a8e7cfa 3692d005106843fd9d3f47812512dd9d "1. Richmond System Wastewater UPG/Civil & Structures/11. Cost Tracking and Productivity"
AddedScope = 5 df90a2d99aff448babde8814a5a32868 3 https://onbmd-my.sharepoint.com/personal/vigkum1_bmd_com_au "0f6c1caf-e6bd-4b86-9946-3771ecd085d5" e0b2263d47d348798ea437a22c68c485 e5b6509eb42d45adab4cd98ad7467fe9 63cf445668814a7c9b7d73f5fa3bd358 789f555a94434fc2b1bab05226a5562b " "
AddedScope = 38 f18d8de82c2841ed8b7c6ef0b100cae4 3 https://onbmd-my.sharepoint.com/personal/alamcd1_bmd_com_au "0f6c1caf-e6bd-4b86-9946-3771ecd085d5" 321afcaa1cd34907b0726077bdfe9892 a311ea329cd94ccbb6c53be67fd6b4c2 e2b906790b1f4885bc0cf1475a5cc674 0cbcb9f16aaa494e8f871d089cefdf59 "Huntingwood"
AddedScope = 72 c93f7286b17949e980b43acf26db2ee5 4 https://onbmd.sharepoint.com/sites/BMS "0f6c1caf-e6bd-4b86-9946-3771ecd085d5" 4913197d65204f858a6b7f90ac2903dc bf5760f9937640aea5b0a5f6f08d91b1 a3230a108b1349a1a5ddfea6c0136770 efe5ddf62e7a43d091469ea87a71fa3e " "
installID = 1
originatorID = 28267675-62f7-4888-806f-264c652cfe33
lastRefreshTime = 1727214039
requestsSent = 389
bytesTransferred = 5315941
uploadLimitKbPerSec = 0
downloadLimitKbPerSec = 0
uploadSpeedAutoLimited = false
edpManaged = false
edpManagedSince = 0
needsPlaceholderTransition = false
pendingPermissionInheritanceChange = None
OfficeOriginatorID = 49e7bfdc-3852-4afa-9ab6-5ea9fc5f5168
lastKnownOSVersion = 10.0.19045
Subscription = 1 fed6c2f80cb14e1586f0263a7d655229 04da9f2e-613a-456b-b9bb-315b95a1fa1a
Subscription = 1 f18d8de82c2841ed8b7c6ef0b100cae4 7b9b8d04-7c60-40cf-b79a-2a25b04b22ce
Subscription = 1 df90a2d99aff448babde8814a5a32868 32199586-cfcb-4179-9f23-35a90dfe2a80
Subscription = 1 c93f7286b17949e980b43acf26db2ee5 dc15078a-f9b7-4cdc-b79a-b22ae68f6100
Subscription = 1 ae03619de9cc47e4b01660d678a766c6+64 ae3a1e4c-4e7d-4457-9364-ea3dbd709f32
Subscription = 1 40b27423fbe744d78f6fb9585c97bbf2+1 36b19ffc-3c70-42bb-9a52-82867011539e
Subscription = 1 0fa45908a231450aafebd9a381627205 7da7095d-59fd-483d-8d3e-6e528c09b3b7

@cristianbuse
Copy link

cristianbuse commented Sep 25, 2024 •
edited
Loading

Hi @itsdalien

Can you please run a check for us? Steps:

  1. Find the line Select Case tag: Case "libraryScope", "libraryFolder", "AddedScope"
  2. Above the line you found at step 1, add this code:
If (tag Like "*libraryScope*") And (Left$(tag, 12) <> "libraryScope") Then Stop
  1. Call GetLocalPath with any web path

Does the code break on the Stopstatement?

@itsdalien
Copy link

itsdalien commented Sep 26, 2024 via email

@cristianbuse
Copy link

@itsdalien

Would you be able to give us additional print screen of the Locals window when the error occurs. It would be useful to see the contents of the sortedLines, libNrToWebColl and the locToWebColl collections. For example:
image

@itsdalien
Copy link

itsdalien commented Sep 26, 2024 via email

@cristianbuse
Copy link

@itsdalien

I finally saw the issue. Apologies for missing it. It is quite subtle.

Your http addresses are not wrapped in double quotes. Whereas all the ini files we've seen so far have it. For example, my first line looks like this:
libraryScope = 0 [cid] 5 "MySite" "ODB" 2 "https://..."
while yours is like this:
libraryScope = 0 [cid] 5 "MySite" "ODB" 2 https://...

Many thanks for your feedback!

I will post a suggested change later today and hopefully you can test it.

@cristianbuse
Copy link

@itsdalien

One other thing, the line starting with libraryScope = 0 ... should contain the local path for your OneDrive but it does not. It only contains the URL. I was expecting somethig like C:\Users\PHIMAT1\One Drive - B.M.D. Holdings Pty. Limited but instead your line simply has "".

What does Environ$("OneDrive") return in VBA?

@itsdalien
Copy link

itsdalien commented Sep 29, 2024 via email

@cristianbuse
Copy link

@itsdalien

When I stop syncing this folder, the code runs as intended.

Can you please share the contents of the ini file after you've stopped syncing. There is no need for the Items collections anymore. Thanks!

@vbrezina
Copy link

vbrezina commented Sep 30, 2024 •
edited
Loading

Hi @guwidoe
I was using GetLocalPath since July with no issue as a migration piece to migrate XLS apps from local disck operation to SharePoint operation. However after a final migration has happened I have observed 2 fatal issues and 1 performance issue. Let me share the details:

One after another:
1. SharePoint folder synced from the middle of the Library folder hierarchy

  • When I had a single Sharepoint library synchronized to my laptop from the very top folder (Documents = technically = Shared Documents) then GetLocalPath was working fine e.g.

  • https://gutorelectronic.sharepoint.com/sites/cs-com/Shared Documents - Documents/07. Tools & Application

  • get converted to

  • C:\Users\VlastimilBrezina\GUTOR ELECTRONIC\Customer Service - Department - Documents\07. Tools & Application

  • When I removed this top level synchronization and replaced that with synchronization from lower level, then GetLocalPath started duplicating 1st folder name in the result

  • e.g. https://gutorelectronic.sharepoint.com/sites/cs-com/Shared Documents 07. Tools & Application/App

  • get converted to

  • C:\Users\VlastimilBrezina\GUTOR ELECTRONIC\Customer Service - Department - 07. Tools & Application*07. Tools & Application*\App

It was causing following set of replacements:
item:=Replace(Replace(path, webRoot, locRoot, , 1), "/", ps)

So I started comparing parts of the paths to fix it:

` 'VBR - path adjustment if first part of webpath = last part of local root to avoid doubling Synced Folder name in result
Dim firstpart_webPath As String, lastpart_locRoot As String

            On Error Resume Next
                
                    ' 1st path part of path behind webRoot in between  slashes e.g. Shared Documents/07. Tools & Application/01. CSB
                    firstpart_webPath = Replace(path, webRoot & "/", "") ' remove webRoot and 1 slash then get string up to next slash
                    firstpart_webPath = Left(firstpart_webPath, InStr(1, firstpart_webPath, "/", vbTextCompare) - 1)
'                Debug.Print "firstpart_webPath : " & firstpart_webPath
                    
                    ' last part of local Root - behind last hyphen e.g. ECTRONIC\Customer Service - Department - 07. Tools & Application
                    lastpart_locRoot = ShP_LastRigtAfter(locRoot, " - ")
                
'                Debug.Print "lastpart_locRoot  : " & lastpart_locRoot
            
            On Error GoTo 0
            
            ' VBR now decide if first part of WebPath equal to last part of local root if yes, remove the duplicate
            Dim itemStr As String, adjPath As String
            
            If firstpart_webPath = lastpart_locRoot And Trim(LCase(Left(path, 5))) = "https" Then
                adjPath = Replace(path, firstpart_webPath & "/", "", 1, 1, vbTextCompare)
                itemStr = Replace(Replace(adjPath, webRoot, locRoot, , 1), "/", ps)
                Debug.Print "Adjusted path result : " & itemStr
            Else
                ' previous implementation - doubling rootfolder in case of lower sync level
                itemStr = Replace(Replace(path, webRoot, locRoot, , 1), "/", ps)
                Debug.Print "Converted Path result (no adjustment) : " & itemStr
            End If
            
            
            
            resColl.Add Key:=vItem(2), _
               Item:=itemStr`

2. Multiple sync folders - resColl.Add Key:=vItem(2), Item:=itemStr` fails with error: "Run-tme error 457 This key is already associated with an element of the collection"

image

3. Issue is performance - if library contains lot of files e.g. a milion, but if synced is just a smarr subfolder - GetLocalPath still takes a lot of time (first run)

Any idea / newer version which is covering cases with multiple sync folders and different then top-level sync ?

Thanks a lot.

In a meanwhile I found that VBA could nicelly work also with https Sharepoint links but following code (e.g. code calculating relative path) has to distinquish if path is https or C:\Users and then decide what separator it should use (\ or /)

@cristianbuse
Copy link

@vbrezina

Can you please test this solution? Just import the LibFileTools module. The function name is the same but you will have to fully qualify it to avoid clashing with Guido's version i.e. LibFileTools.GetLocalPath. Is 1) and 2) you raised above still an issue using my version? As for 3) the performance should be the same as Guido and I developed both solutions simultaneously.

@cristianbuse
Copy link

cristianbuse commented Oct 1, 2024 •
edited
Loading

@itsdalien

Can I please ask that you also test the solution I linked in the above comment? If that works then I can make the suggested changes here as well.

I just updated a fork for this gist here. Maybe try this directly.

@itsdalien
Copy link

itsdalien commented Oct 1, 2024 via email

@cristianbuse
Copy link

@itsdalien I am using Office 365 x64 myself. Try downloading from the zip and then import LibFileTools using the Import feature in VBE (do not copy-paste code)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment