Last active
October 23, 2022 16:20
-
-
Save guwidoe/bc875f4f25e0e970c62959d3c59da1d6 to your computer and use it in GitHub Desktop.
VB.NET Function to get the local path of a OneDrive/SharePoint synchronized Microsoft Office file
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ' VB.NET Function to get the local path of OneDrive/SharePoint synchronized | |
| ' Microsoft Office files | |
| ' | |
| ' Author: Guido Witt-Dörring | |
| ' Created: 2022/07/01 | |
| ' Updated: 2022/10/20 | |
| ' License: MIT | |
| ' | |
| ' ---------------------------------------------------------------- | |
| ' https://gist.github.com/guwidoe/bc875f4f25e0e970c62959d3c59da1d6 | |
| ' ---------------------------------------------------------------- | |
| ' | |
| ' Copyright (c) 2022 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. | |
| ' This is a VB.NET port of the VBA function published here: | |
| ' https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d | |
| Public Function GetLocalPath(ByVal Path As String, | |
| Optional ByVal rebuildCache As Boolean = False, | |
| Optional ByVal returnAll As Boolean = False, | |
| Optional ByVal preferredMountPointOwner As String = "") _ | |
| As String | |
| #If Mac Then | |
| GetLocalPath = Path: Exit Function | |
| #End If | |
| Dim webRoot As String, locRoot As String, vKey As String | |
| Static locToWebDict As Dictionary(Of String, String) | |
| Static actLocToWebDict As Dictionary(Of String, String) | |
| Static locPathOwners As Dictionary(Of String, String) | |
| Dim resDict As Dictionary(Of String, String) | |
| resDict = New Dictionary(Of String, String) | |
| preferredMountPointOwner = LCase(preferredMountPointOwner) | |
| If Not actLocToWebDict Is Nothing And Not rebuildCache Then | |
| For Each pair As KeyValuePair(Of String, String) In actLocToWebDict | |
| locRoot = pair.Key : webRoot = pair.Value | |
| If InStr(1, Path, webRoot, vbBinaryCompare) = 1 Then _ | |
| resDict.Add(locPathOwners(pair.Key), | |
| Replace(Replace(Path, webRoot, locRoot, , 1), "/", "\")) | |
| Next | |
| If resDict.Count = 0 Then Return Path | |
| If returnAll Then _ | |
| Return Join(resDict.Values.ToArray, "/") | |
| If resDict.ContainsKey(preferredMountPointOwner) Then _ | |
| Return resDict(preferredMountPointOwner) | |
| Return resDict.Values(0) | |
| End If | |
| locToWebDict = Nothing | |
| locPathOwners = Nothing | |
| locToWebDict = New Dictionary(Of String, String) | |
| actLocToWebDict = New Dictionary(Of String, String) | |
| locPathOwners = New Dictionary(Of String, String) | |
| Dim cid As String, fileNumber As Long, line As String, parts() As String | |
| Dim tag As String, mainMount As String, relPath As String | |
| Dim b() As Byte, n As Integer, i As Integer, j As Integer, k As Integer | |
| Dim l As Integer, s As String, bs As String, size As Long | |
| Dim parentID As String, folderID As String, folderName As String | |
| Dim folderIdPattern As String : folderIdPattern = "" | |
| Dim fileName As String, folderType As String | |
| Dim siteID As String, libID As String, webID As String, lnkID As String | |
| Dim odFolders As Dictionary(Of String, KeyValuePair(Of String, String)) | |
| Dim cliPolDict As Dictionary(Of String, Dictionary(Of String, String)) | |
| Dim UserEmail As String | |
| Const sig1 As Byte = &H2 | |
| Dim vbNullByte As Byte | |
| vbNullByte = &H0 'VBA: MidB$(vbNullChar, 1, 1) | |
| Dim settPath As String, wDir As String, clpPath As String | |
| settPath = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\" | |
| clpPath = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\" | |
| 'Find all subdirectories in OneDrive settings folder: | |
| Dim oneDriveSettDirs() As DirectoryInfo | |
| oneDriveSettDirs = New DirectoryInfo(settPath).GetDirectories() | |
| Dim dirName As String | |
| cid = "" | |
| 'Writing LocToWebDict using .ini and .dat files in the OneDrive settings: | |
| For Each oneDriveSettDir As IO.DirectoryInfo In oneDriveSettDirs | |
| dirName = oneDriveSettDir.Name | |
| wDir = settPath & dirName & "\" | |
| 'Read global.ini to get cid | |
| If Dir(wDir & "global.ini", vbNormal) = "" Then GoTo NextFolder | |
| Using fileStream = New FileStream(wDir & "global.ini", FileMode.Open, | |
| FileAccess.Read, FileShare.ReadWrite) | |
| Using streamReader = New StreamReader(fileStream, Encoding.Unicode) | |
| s = streamReader.ReadToEnd() | |
| End Using | |
| End Using | |
| For Each line In Split(s, vbCrLf) | |
| parts = Split(line, " = ") | |
| If parts(0) = "cid" Then : cid = parts(1) : Exit For : End If | |
| Next line | |
| If cid = "" Then GoTo NextFolder | |
| If (Dir(wDir & cid & ".ini") = "" Or | |
| Dir(wDir & cid & ".dat") = "") Then GoTo NextFolder | |
| If dirName Like "Business#" Then | |
| folderIdPattern = Replace(Space(32), " ", "[a-f0-9]") | |
| ElseIf dirName = "Personal" Then | |
| folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*" | |
| End If | |
| 'Get UserEmail for business accounts | |
| '(only necessary to let user choose preferredMountPointOwner) | |
| fileName = Dir(clpPath, vbNormal) | |
| UserEmail = "" | |
| Do Until fileName = "" | |
| If InStr(1, fileName, cid) And cid <> "" Then _ | |
| UserEmail = LCase(Left(fileName, InStr(fileName, cid) - 2)) : _ | |
| Exit Do | |
| fileName = Dir() | |
| Loop | |
| 'Read all the ClientPloicy.ini files: | |
| cliPolDict = New Dictionary(Of String, Dictionary(Of String, String)) | |
| fileName = Dir(wDir, vbNormal) | |
| Do Until fileName = "" | |
| If fileName Like "ClientPolicy*.ini" Then | |
| Using fileStream = New FileStream(wDir & fileName, FileMode.Open, | |
| FileAccess.Read, FileShare.ReadWrite) | |
| Using streamReader = New StreamReader(fileStream, Encoding.Unicode) | |
| bs = streamReader.ReadToEnd() | |
| End Using | |
| End Using | |
| cliPolDict(fileName) = New Dictionary(Of String, String) | |
| For Each line In Split(bs, vbCrLf) | |
| If InStr(1, line, " = ", vbBinaryCompare) Then | |
| parts = Split(line, " = ") : tag = parts(0) | |
| s = Replace(line, tag & " = ", "", , 1) | |
| Select Case tag | |
| Case "DavUrlNamespace" | |
| cliPolDict(fileName).Add(tag, s) | |
| Case "SiteID" | |
| s = Replace(LCase(s), "-", "") | |
| If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2) | |
| cliPolDict(fileName).Add(tag, s) | |
| Case "IrmLibraryId" | |
| s = Replace(LCase(s), "-", "") | |
| If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2) | |
| cliPolDict(fileName).Add(tag, s) | |
| Case "WebID" | |
| s = Replace(LCase(s), "-", "") | |
| If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2) | |
| cliPolDict(fileName).Add(tag, s) | |
| End Select | |
| End If | |
| Next line | |
| End If | |
| fileName = Dir() | |
| Loop | |
| 'Read dirName\cid.dat file | |
| Using fileStream = New FileStream(wDir & cid & ".dat", FileMode.Open, | |
| FileAccess.Read, FileShare.ReadWrite) | |
| Using byteReader = New BinaryReader(fileStream) | |
| Dim length = byteReader.BaseStream.Length | |
| b = byteReader.ReadBytes(length) | |
| End Using | |
| End Using | |
| size = b.Count - 1 | |
| odFolders = New Dictionary(Of String, KeyValuePair(Of String, String)) | |
| For j = 16 To 8 Step -8 | |
| i = j + 1 | |
| Do While i > j And i < size - 168 | |
| If b(i) = sig1 Then | |
| i += 16 | |
| If Not b(i) = &H1 Then Continue Do | |
| For k = 1 To 7 | |
| i += 1 | |
| If Not b(i) = &H0 Then Continue Do | |
| Next | |
| k = i + 1 | |
| Do Until b(k) = &H0 Or k - i > 128 | |
| k += 1 | |
| Loop | |
| l = k - i | |
| If l > 128 Then | |
| i += l | |
| Continue Do | |
| End If | |
| If l > 39 Then : l = 39 : End If | |
| If l < 1 Then : l = 1 : End If | |
| folderID = Encoding.Unicode.GetString( | |
| Encoding.Convert(Encoding.ASCII, | |
| Encoding.Unicode, b.Skip(i + 1).Take(l - 1).ToArray())) | |
| i += 39 | |
| k = i + 1 | |
| Do Until b(k) = &H0 Or k - i > 128 | |
| k = k + 1 | |
| Loop | |
| l = k - i | |
| If l > 128 Then | |
| i += l | |
| Continue Do | |
| End If | |
| If l > 39 Then : l = 39 : End If | |
| If l < 1 Then : l = 1 : End If | |
| parentID = Encoding.Unicode.GetString( | |
| Encoding.Convert(Encoding.ASCII, | |
| Encoding.Unicode, b.Skip(i + 1).Take(l - 1).ToArray())) | |
| i += 121 | |
| k = i + 1 | |
| Do Until (b(k) = &H0 And b(k + 1) = &H0) Or k > size | |
| k = k + 2 | |
| Loop | |
| l = k - i | |
| folderName = Encoding.Unicode.GetString( | |
| b.Skip(i + 1).Take(l - 1).ToArray()) | |
| If folderID Like folderIdPattern Then | |
| If Not odFolders.ContainsKey(folderID) Then | |
| odFolders.Add(folderID, New KeyValuePair(Of String, | |
| String)(parentID, folderName)) | |
| End If | |
| End If | |
| End If | |
| i += 1 | |
| Loop | |
| Next j | |
| 'Read relevant .ini files | |
| Using fileStream = New FileStream(wDir & cid & ".ini", FileMode.Open, | |
| FileAccess.Read, FileShare.ReadWrite) | |
| Using streamReader = New StreamReader(fileStream, Encoding.Unicode) | |
| s = streamReader.ReadToEnd() | |
| End Using | |
| End Using | |
| Select Case True | |
| Case dirName Like "Business#" | |
| 'Max 9 Business OneDrive accounts can be signed in at a time. | |
| mainMount = "" | |
| For Each line In Split(s, vbCrLf) | |
| Select Case Left(line, InStr(line, " = ") - 1) | |
| Case "libraryScope" | |
| webRoot = "" : parts = Split(line, """") : locRoot = parts(9) | |
| If locRoot = "" Then locRoot = Split(line, " ")(2) '=libNr | |
| folderType = parts(3) : parts = Split(parts(8), " ") | |
| siteID = parts(1) : webID = parts(2) : libID = parts(3) | |
| If mainMount = "" And folderType = "ODB" Then | |
| mainMount = locRoot : fileName = "ClientPolicy.ini" | |
| If cliPolDict.ContainsKey(fileName) Then _ | |
| webRoot = cliPolDict(fileName)("DavUrlNamespace") | |
| Else | |
| fileName = "ClientPolicy_" & libID & siteID & ".ini" | |
| If cliPolDict.ContainsKey(fileName) Then _ | |
| webRoot = cliPolDict(fileName)("DavUrlNamespace") | |
| End If | |
| If webRoot = "" Then 'Backup if previous method doesn't work | |
| For Each pair As KeyValuePair(Of String, | |
| Dictionary(Of String, String)) In cliPolDict | |
| If pair.Value("SiteID") = siteID And pair.Value("WebID") = | |
| webID And pair.Value("IrmLibraryId") = libID Then | |
| webRoot = pair.Value("DavUrlNamespace") : Exit For | |
| End If | |
| Next | |
| End If | |
| locToWebDict.Add(locRoot, webRoot) | |
| Case "libraryFolder" | |
| webRoot = "" : locRoot = Split(line, """")(1) | |
| libID = Split(line, " ")(3) | |
| For Each vKey In locToWebDict.Keys | |
| If vKey = libID Then | |
| s = "" : parentID = Left(Split(line, " ")(4), 32) | |
| Do Until Not odFolders.ContainsKey(parentID) | |
| s = odFolders(parentID).Value & "/" & s | |
| parentID = odFolders(parentID).Key | |
| Loop | |
| webRoot = locToWebDict(vKey) & s : Exit For | |
| End If | |
| Next vKey | |
| locToWebDict.Add(locRoot, webRoot) | |
| Case "AddedScope" | |
| webRoot = "" : parts = Split(line, """") | |
| relPath = parts(5) : If relPath = " " Then relPath = "" | |
| parts = Split(parts(4), " ") : siteID = parts(1) | |
| webID = parts(2) : libID = parts(3) : lnkID = parts(4) | |
| fileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini" | |
| If cliPolDict.ContainsKey(fileName) Then | |
| webRoot = cliPolDict(fileName)("DavUrlNamespace") _ | |
| & relPath : End If | |
| If webRoot = "" Then 'Backup if previous method doesn't work | |
| For Each pair As KeyValuePair(Of String, | |
| Dictionary(Of String, String)) In cliPolDict | |
| If pair.Value("SiteID") = siteID And pair.Value("WebID") = | |
| webID And pair.Value("IrmLibraryId") = libID Then | |
| webRoot = pair.Value("DavUrlNamespace") & relPath | |
| Exit For | |
| End If | |
| Next | |
| End If | |
| s = "" : parentID = Left(Split(line, " ")(3), 32) | |
| Do Until Not odFolders.ContainsKey(parentID) | |
| s = odFolders(parentID).Value & "\" & s | |
| parentID = odFolders(parentID).Key | |
| Loop | |
| locRoot = mainMount & "\" & s | |
| locToWebDict.Add(locRoot, webRoot) | |
| Case Else | |
| For Each pair As KeyValuePair(Of String, String) In locToWebDict | |
| If pair.Key Like "#*" Then locToWebDict.Remove(pair.Key) | |
| Next | |
| Exit For | |
| End Select | |
| Next line | |
| Case dirName = "Personal" | |
| 'Only one Personal OneDrive account can be signed in at a time. | |
| If Not cliPolDict.ContainsKey("ClientPolicy.ini") Then GoTo NextFolder | |
| For Each line In Split(s, vbCrLf) | |
| If line Like "library = *" Then _ | |
| locRoot = Split(line, """")(3) : Exit For | |
| Next line | |
| webRoot = cliPolDict("ClientPolicy.ini")("DavUrlNamespace") | |
| If webRoot = "" Or locRoot = "" Or cid = "" Then GoTo NextFolder | |
| locToWebDict(locRoot) = webRoot & "/" & cid | |
| If Dir(wDir & "GroupFolders.ini") = "" Then GoTo NextFolder | |
| Using fileStream = New FileStream(wDir & "GroupFolders.ini", | |
| FileMode.Open, | |
| FileAccess.Read, FileShare.ReadWrite) | |
| Using streamReader = New StreamReader(fileStream, Encoding.Unicode) | |
| s = streamReader.ReadToEnd() | |
| End Using | |
| End Using | |
| cid = "" | |
| For Each line In Split(s, vbCrLf) | |
| If InStr(1, line, "BaseUri = ") And cid = "" Then | |
| cid = LCase(Mid(line, InStrRev(line, "/") + 1, 16)) | |
| folderID = Left(line, InStr(line, "_") - 1) | |
| ElseIf cid <> "" Then | |
| locToWebDict.Add(locRoot & "\" & odFolders(folderID).Value, | |
| webRoot & "/" & cid & "/" & | |
| Replace(line, folderID & "_Path = ", "")) | |
| cid = "" : folderID = "" | |
| End If | |
| Next line | |
| End Select | |
| For Each pair As KeyValuePair(Of String, String) In locToWebDict | |
| locRoot = pair.Key : webRoot = pair.Value | |
| If Right(webRoot, 1) = "/" Then | |
| webRoot = Left(webRoot, Len(webRoot) - 1) | |
| End If | |
| If Right(locRoot, 1) = "\" Then | |
| locRoot = Left(locRoot, Len(locRoot) - 1) | |
| End If | |
| actLocToWebDict(locRoot) = webRoot | |
| If Not locPathOwners.ContainsKey(locRoot) Then | |
| locPathOwners.Add(locRoot, UserEmail) | |
| End If | |
| Next | |
| NextFolder: | |
| cid = "" : s = "" : UserEmail = "" : odFolders = Nothing | |
| Next | |
| Return GetLocalPath(Path, False, returnAll, preferredMountPointOwner) | |
| End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment