GetLocalPath doesn't work in all cases #1
Comments
|
Hello, Thanks for raising the issue and for your kind words! Is there a reason why you would like to convert a web path to a local path for an account that is not logged in? Based on your answer to the above, I might switch to the SyncEngines path or not but in either case I would like to be able to fix the subfolder issue. As I do not have this issue on my personal or business accounts I could surely use your help with some screenshots of the keys in both the SyncEngines folder and the Software\Microsoft\OneDrive\Accounts\ folder. Please let me know your thoughts on the first question and if you can help with more info on the keys. Thanks! Cristian |
|
Hi, Thanks for your quick reply!
I think you slightly misunderstood the first problem I mentioned, this is not what I'm trying to do. The mentioned "Personal (Business) OneDrive" folder and the "SharePoint" folder belong to the same account (which is indeed logged in) and still have different WebPath roots. I can gladly provide a screenshot: (only the company name is censored) As you can see, by only reading For the logged out personal account, the registry contains nothing, as expected: Here are some screenshots of the SyncEngines Registry: I wrote a test sub that contains all variations of WebPaths I'm currently aware of and just tested a bunch of solutions to the issue I found online. As expected, most of them failed at least some tests. In fact, there was only one solution of like 15 I tested which passed all the tests, and it did so to my great surprise, because it was posted on StackOverflow by a user with a mere 21 reputation. If only works for files or folders that exist and it runs very slowly so I'm sure it can be improved a lot. After reading his solution it seems the only reason it runs so slow is that he doesn't use the registry to get the information about the local paths but the OneDrive settings file instead. And It overcomes the intermediate path part problem using the Dir function, similar to how I suggested in my original post. Private Function GetLocalPath(path As String) As String
Const HKEY_CURRENT_USER = &H80000001
Dim objReg As Object
Dim regPath As String
Dim subKeys() As Variant
Dim subKey As Variant
Dim strValue As String
Dim strMountpoint As String
Dim strSecPart As String
Static pathSep As String
If pathSep = "" Then pathSep = Application.PathSeparator
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
regPath = "Software\SyncEngines\Providers\OneDrive\"
objReg.EnumKey HKEY_CURRENT_USER, regPath, subKeys
For Each subKey In subKeys
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, _
"UrlNamespace", strValue
If InStr(path, strValue) > 0 Then
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, _
"MountPoint", strMountpoint
strSecPart = Replace(Mid(path, Len(strValue)), "/", pathSep)
GetLocalPath = strMountpoint & strSecPart
Do Until Dir(GetLocalPath, vbDirectory) <> "" Or _
InStr(2, strSecPart, pathSep) = 0
strSecPart = Mid(strSecPart, InStr(2, strSecPart, pathSep))
GetLocalPath = strMountpoint & strSecPart
Loop
Exit Function
End If
Next
GetLocalPath = path
End FunctionEDIT: |
|
I now did further testing and also logged into a personal OneDrive account on my device. It seems the solution I linked doesn't work for personal OneDrive folders, but the one I suggested does work. I found another solution that does also work for folders that don't exist, however, it has other shortcomings which I pointed out in the comments to the StackOverflow post. |
|
Out of curiosity, if you replace Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) = 0 Then Exit Function
'
Static isSet As Boolean
Static arrLocal(0 To 1) As String
Static arrWeb(0 To 1) As String
Dim i As Long
Dim tempPath As String
'
If Not isSet Then
arrLocal(0) = Environ$("OneDriveCommercial")
arrLocal(1) = Environ$("OneDriveConsumer")
'
Dim v As Variant
Dim repaintOn As Boolean: repaintOn = Application.ScreenUpdating
Dim alertsOn As Boolean: alertsOn = Application.DisplayAlerts
Dim eventsOn As Boolean: eventsOn = Application.EnableEvents
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
For Each v In arrLocal
If LenB(v) > 0 Then
tempPath = BuildPath(v, "temp.xlsx")
With Application.Workbooks.Add
.SaveAs tempPath, XlFileFormat.xlOpenXMLWorkbook
arrWeb(i) = Left$(.FullName, InStrRev(.FullName, "/") - 1)
.Close SaveChanges:=False
Kill tempPath
End With
End If
i = i + 1
Next v
On Error GoTo 0
If repaintOn Then Application.ScreenUpdating = True
If alertsOn Then Application.DisplayAlerts = True
If eventsOn Then Application.EnableEvents = True
isSet = True
End If
'
For i = LBound(arrWeb) To UBound(arrWeb)
tempPath = arrWeb(i)
Dim lo As Long: lo = Len(tempPath)
If lo > 0 Then
If Len(odWebPath) > lo Then
If StrComp(tempPath, Left$(odWebPath, lo), vbTextCompare) = 0 Then
GetOneDriveLocalPath = Replace(odWebPath, tempPath, arrLocal(i), , , vbTextCompare)
Exit Function
End If
End If
End If
Next i
End FunctionThanks! |
|
Hello, I tested it and unfortunately, it didn't work in a single case. In all except one case, it returned nothing and in one case it returned the right path but with some wrong PathSeparators. |
|
That's really strange. I was expecting that it works for all cases since it's using Excel's internal logic with no registry 'hack'. Does your solution work where the Excel fails? Could you give me the path(s) where it failed? Thanks! |
|
As a side note, Sub AllEnvironVariables()
Dim strEnviron As String
Dim VarSplit As Variant
Dim i As Long
For i = 1 To 255
strEnviron = Environ$(i)
If LenB(strEnviron) = 0& Then GoTo TryNext:
Debug.Print strEnviron
TryNext:
Next
End SubI have only two OneDrive Environ variables defined, My solution works in all cases except if the file/folder doesn't exist. |
|
These are the tests I can share, I'm using this test script: Sub TestGetLocalPath(TestName As String, oneDrivePath As String, localPath As String)
If Not GetLocalPath(oneDrivePath) = localPath Then
Debug.Print vbNewLine & TestName & " ERROR:"
Debug.Print "URL path: " & oneDrivePath
Debug.Print "Func ret: " & GetLocalPath(oneDrivePath)
Debug.Print "act path: " & localPath & vbNewLine
Else
Debug.Print TestName & " PASSED"
End If
End SubEDIT: I have now updated my tests so I can share all of them: TestGetLocalPath "Test Company SharePoint", _
"https://abconline.sharepoint.com/sites/ACEA/Freigegebene Dokumente/General/2021/04_Working/- Archiv -/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\ACEA - General\2021\04_Working\- Archiv -\test.xlsm"
TestGetLocalPath "Test2 Company SharePoint", _
"https://abconline.sharepoint.com/sites/AI/Freigegebene Dokumente/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\AI - Dokumente\Test\test.xlsm"
TestGetLocalPath "Test3 Company SharePoint, (file that doesn't exist, but in top lvl directory)", _
"https://abconline.sharepoint.com/sites/workspaces/ntbas/Shared Documents/Test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\NTB After Sales - Documents\Test.xlsm"
TestGetLocalPath "Test4 Company SharePoint", _
"https://abconline.sharepoint.com/sites/workspaces/NTB/Shared Documents/100_Business Development/", _
"C:\Users\Witt-DörringGuidoABC\ABC\NTB - Documents\100_Business Development\"
TestGetLocalPath "Test Personal Business OneDrive", _
"https://abconline-my.sharepoint.com/personal/gwitt-doerring_abc_at/Documents/-Test-/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive - ABC\-Test-\test.xlsm"
TestGetLocalPath "Test Personal Business OneDrive shared by someone else (mounts to SharePoint on local sync!)", _
"https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Beispiel import.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Beispiel import.xlsm"
TestGetLocalPath "Test Private OneDrive folder", _
"https://d.docs.live.net/f1189d8c9189d493/Testfolder_toplvl/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Testfolder_toplvl\test.xlsm"
TestGetLocalPath "Test2 Personal Business OneDrive shared by someone else (nonexistant folder)", _
"https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Test/", _
"C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Test\"
TestGetLocalPath "Test3 Private SharePoint shared by someone else (secone level folder mount)", _
"https://d.docs.live.net/5cfc6adc55f2ae2b/FirstLevel/SecondLevel/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\SecondLevel\test.xlsm"
TestGetLocalPath "Test4 Private SharePoint shared by someone else (second level folder mount with tricky name)", _
"https://d.docs.live.net/5cfc6adc55f2ae2b/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test\Test\test.xlsm"Results with your latest function: Results with my function: |
|
This ( Option Explicit
Private Type OneDriveProvider
UrlNamespace As String
MountPoint As String
isSet As Boolean
End Type
Private Type OneDriveProviders
arr() As OneDriveProvider
pCount As Long
isSet As Boolean
End Type
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) = 0 Then Exit Function
'
Static providers As OneDriveProviders
Static isSet As Boolean
Dim i As Long
'
If LenB(odWebPath) = 0 Then Exit Function
If Not providers.isSet Then
providers = GetProviders()
providers.isSet = True
End If
For i = 1 To providers.pCount
With providers.arr(i)
If StrComp(Left$(odWebPath, Len(.UrlNamespace)), .UrlNamespace, vbTextCompare) = 0 Then
If Not .isSet Then SetProvider providers.arr(i)
GetOneDriveLocalPath = BuildPath(.MountPoint, Replace(odWebPath, .UrlNamespace, vbNullString))
Exit Function
End If
End With
Next i
End Function
Private Function GetProviders() As OneDriveProviders
Const HKEY_CURRENT_USER = &H80000001
Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
Dim objReg As Object
Dim subKeys() As Variant
Dim subKey As Variant
Dim i As Long
'
On Error GoTo CleanExit
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
objReg.EnumKey HKEY_CURRENT_USER, regPath, subKeys
'
With GetProviders
.pCount = UBound(subKeys) - LBound(subKeys) + 1
ReDim .arr(1 To .pCount)
i = 1
For Each subKey In subKeys
With .arr(i)
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, "UrlNamespace", .UrlNamespace
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, "MountPoint", .MountPoint
End With
i = i + 1
Next subKey
End With
CleanExit:
End Function
Private Sub SetProvider(ByRef provider As OneDriveProvider)
Dim repaintOn As Boolean: repaintOn = Application.ScreenUpdating
Dim alertsOn As Boolean: alertsOn = Application.DisplayAlerts
Dim eventsOn As Boolean: eventsOn = Application.EnableEvents
Dim tempPath As String
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'
tempPath = BuildPath(provider.MountPoint, "temp.xlsx")
If Not IsFile(tempPath) Then
On Error Resume Next
With Application.Workbooks.Add
.SaveAs tempPath, XlFileFormat.xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
On Error GoTo 0
End If
With Application.Workbooks.Open(tempPath, False, False)
provider.UrlNamespace = Left$(.FullName, InStrRev(.FullName, "/") - 1)
.Close SaveChanges:=False
Kill tempPath
End With
On Error GoTo 0
'
If repaintOn Then Application.ScreenUpdating = True
If alertsOn Then Application.DisplayAlerts = True
If eventsOn Then Application.EnableEvents = True
'
provider.isSet = True
End Sub |
|
I won't be able to test it until Sunday because I'm not home and don't have my pc with me. I'll let you know if it works once I'm back. Creating a temporary file might indeed be annoying since it slows everything down significantly... I think I'd rather have it only work on existing files/folders. I can't really think of a use case where I'd need it for non-existent files anyways. I pretty much only use it to convert |
|
I now tested your proposed solution and it did pretty well. There were some access denied errors at the Test wise, almost all of the tests passed, the output looked like this: It passed the non-existent folder Test, which my function failed, but something went wrong on the last two tests. To me it currently doesn't seem practical like that, I'd much rather continue to use my solution. I do find the idea very interesting though, do you think you might find a way to solve it without the file-saving step? |
|
Hi @guwidoe Do you think you can test the below? Option Explicit
Private Type OneDriveProvider
urlNamespace As String
mountPoint As String
End Type
Private Type OneDriveProviders
arr() As OneDriveProvider
pCount As Long
isSet As Boolean
End Type
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) = 0 Then Exit Function
'
Static providers As OneDriveProviders
Static isSet As Boolean
Dim i As Long
'
If LenB(odWebPath) = 0 Then Exit Function
If Not providers.isSet Then
providers = GetProviders()
providers.isSet = True
End If
For i = 1 To providers.pCount
With providers.arr(i)
If StrComp(Left$(odWebPath, Len(.urlNamespace)), .urlNamespace, vbTextCompare) = 0 Then
GetOneDriveLocalPath = BuildPath(.mountPoint, Replace(odWebPath, .urlNamespace, vbNullString))
Exit Function
End If
End With
Next i
End Function
Private Function GetProviders() As OneDriveProviders
Const HKEY_CURRENT_USER = &H80000001
Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
Dim oReg As Object
Dim subKeys() As Variant
Dim subKey As Variant
Dim i As Long
'
On Error GoTo CleanExit
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
oReg.EnumKey HKEY_CURRENT_USER, regPath, subKeys
'
With GetProviders
.pCount = UBound(subKeys) - LBound(subKeys) + 1
ReDim .arr(1 To .pCount)
i = 1
For Each subKey In subKeys
Dim fullKey As String: fullKey = regPath & subKey
With .arr(i)
oReg.GetStringValue HKEY_CURRENT_USER, fullKey, "UrlNamespace", .urlNamespace
oReg.GetStringValue HKEY_CURRENT_USER, fullKey, "MountPoint", .mountPoint
If StrComp(.urlNamespace, "https://d.docs.live.net", vbTextCompare) = 0 Then
Dim cID As String: oReg.GetStringValue HKEY_CURRENT_USER, fullKey, "CID", cID
.urlNamespace = .urlNamespace & "/" & cID
Else
FixProviderIfNeeded GetProviders.arr(i)
End If
End With
i = i + 1
Next subKey
End With
CleanExit:
End Function
Private Sub FixProviderIfNeeded(ByRef provider As OneDriveProvider)
Dim fLocal As String
Dim fWeb As String
Dim arrParts() As String
Dim lastPart As String
Dim tempPath As Variant
'
With provider
If Right$(.mountPoint, 1) = "\" Then
.mountPoint = Left$(.mountPoint, Len(.mountPoint) - 1)
End If
If Right$(.urlNamespace, 1) = "/" Then
.urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
End If
'
fLocal = Right$(.mountPoint, Len(.mountPoint) - InStrRev(.mountPoint, "\"))
If InStr(1, fLocal, " - ") = 0 Then Exit Sub
'
arrParts = Split(fLocal, " - ")
If arrParts(0) = "OneDrive" Then Exit Sub
'
fWeb = Right$(.urlNamespace, Len(.urlNamespace) - InStrRev(.urlNamespace, "/"))
lastPart = arrParts(UBound(arrParts))
If fWeb Like "* " & lastPart Then Exit Sub
'
For Each tempPath In Array(.urlNamespace & "/" & lastPart _
, .urlNamespace & "/Documents/" & lastPart)
If IsValidSharepointPath(tempPath) Then
.urlNamespace = tempPath
Exit Sub
End If
Next tempPath
End With
End Sub
Public Function IsValidSharepointPath(ByVal path As String) As Boolean
Dim defPath As String
With Application.FileDialog(msoFileDialogOpen)
defPath = .InitialFileName
.InitialFileName = Environ$("LOCALAPPDATA")
If Right$(path, 1) <> "/" Then path = path & "/"
.InitialFileName = path
IsValidSharepointPath = (InStr(1, .InitialFileName, "https://", vbTextCompare) > 0)
.InitialFileName = defPath
End With
End FunctionThanks! |
|
Ok, I have no idea what kind of dark magic you are doing here but these are my results. If I started Excel with an active Internet connection, the first time I call GetLocalPath it takes a bit, maybe like 2-3 seconds, and then subsequent executions of the function are instant and the tests pass just like last time until I restart the application. Now if I start the application without an active internet connection and then run my test sub without internet connection, I get these results: It seems, that here, all the tests failed where the synchronized folder is not at the bottom of the server folder hierarchy. |
|
@guwidoe Thanks for the above! It is really usefull. It takes longer first time as the The I've been playing around with the FileSyncLibrary (COM) but unfortunately it led me nowhere as most of it's functionality is not even compatible with VBA. This would have been awesome to be able to use. You correctly identified that the issue lies with synchronized folders that are not at the bottom of the server folder hierarchy. Same with all my tests. Really annoying. Will try a few more things in the next few days. Again, many thanks! |
|
Hi @guwidoe , It would be great if you could test the below: Option Explicit
Private Type OneDriveProvider
urlNamespace As String
mountPoint As String
actualFolder As String
isSet As Boolean
isBusiness As Boolean
End Type
Private Type OneDriveProviders
arr() As OneDriveProvider
pCount As Long
isSet As Boolean
End Type
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) = 0 Then Exit Function
'
Static providers As OneDriveProviders
Static isSet As Boolean
Dim i As Long
Dim rPart As String
Dim tempPart As String
Dim p As Long
Dim tempActual As String
Dim multiOccurence As Boolean
'
If LenB(odWebPath) = 0 Then Exit Function
If Not providers.isSet Then
providers = GetRegistryProviders()
FixBusinessProviders providers
providers.isSet = True
End If
For i = 1 To providers.pCount
With providers.arr(i)
If StrComp(Left$(odWebPath, Len(.urlNamespace)), .urlNamespace, vbTextCompare) = 0 Then
rPart = Replace(odWebPath, .urlNamespace, vbNullString)
If Not .isSet Then
tempActual = "/" & .actualFolder & "/"
p = InStr(1, rPart, tempActual, vbTextCompare)
If p = 0 Then Exit Function
'
multiOccurence = (InStr(p + 1, rPart, tempActual, vbTextCompare) > 0)
tempPart = Mid$(rPart, p + IIf(.isBusiness, Len(tempActual), 0))
'
If multiOccurence Then
Do Until LenB(Dir(BuildPath(.mountPoint, tempPart), vbDirectory)) > 0
p = InStr(IIf(.isBusiness, 1, p + 1), rPart, tempActual, vbTextCompare)
If p = 0 Then Exit Do
tempPart = Mid$(rPart, p + IIf(.isBusiness, Len(tempActual), 0))
Loop
End If
rPart = tempPart
End If
GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
Exit Function
End If
End With
Next i
End Function
Private Function GetRegistryProviders() As OneDriveProviders
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
Dim oReg As Object
Dim subKeys() As Variant
Dim subKey As Variant
Dim i As Long
'
On Error GoTo CleanExit
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
oReg.EnumKey HKCU, regPath, subKeys
'
With GetRegistryProviders
.pCount = UBound(subKeys) - LBound(subKeys) + 1
ReDim .arr(1 To .pCount)
i = 1
For Each subKey In subKeys
ReadRegistryProvider oReg, regPath & subKey, .arr(i)
i = i + 1
Next subKey
End With
CleanExit:
End Function
Private Function ReadRegistryProvider(ByVal oReg As Object _
, ByVal regKey As String _
, ByRef provider As OneDriveProvider)
Const HKCU = &H80000001
Dim cid As String
Dim aFolder As String
'
With provider
oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
'
.isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
If .isBusiness Then
If Right$(.urlNamespace, 1) = "/" Then
.urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
End If
Else
oReg.GetStringValue HKCU, regKey, "CID", cid
oReg.GetStringValue HKCU, regKey, "RelativePath", .actualFolder
'
.urlNamespace = .urlNamespace & "/" & cid
.isSet = (LenB(.actualFolder) = 0)
End If
End With
End Function
Private Sub FixBusinessProviders(ByRef providers As OneDriveProviders)
Dim settingsPath As String
Dim folderPath As Variant
Dim folderName As String
Dim iniName As String
'
settingsPath = Environ$("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
For Each folderPath In GetFolders(settingsPath)
folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
If folderName Like "Business*" Then
iniName = Dir(BuildPath(folderPath, "????????-????-????-????-????????????.ini"))
If LenB(iniName) > 0 Then
FixFromSettingsFile BuildPath(folderPath, iniName), providers
End If
End If
Next folderPath
End Sub
Private Sub FixFromSettingsFile(ByVal filePath As String _
, ByRef providers As OneDriveProviders)
Dim fileNumber As Long
Dim lineText As String
Dim arrParts() As String
Dim tempMount As String
Dim tempURL As String
Dim i As Long
'
On Error Resume Next
fileNumber = FreeFile
Open filePath For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
arrParts = Split(lineText, " ")
Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
Case "libraryScope"
arrParts = Split(lineText, """")
tempMount = arrParts(9)
If LenB(tempMount) > 0 Then
tempURL = arrParts(5)
Do
i = GetProviderIndexByURL(providers, tempURL)
If i > 0 Then providers.arr(i).isSet = True
Loop Until i = 0
End If
Case "libraryFolder"
arrParts = Split(lineText, """")
tempMount = arrParts(1)
providers.arr(GetProviderIndexByPath(providers, tempMount)).actualFolder = arrParts(3)
Case "AddedScope"
arrParts = Split(lineText, """")
tempURL = arrParts(1)
With providers.arr(GetProviderIndexByURL(providers, tempURL))
.urlNamespace = .urlNamespace & "/" & arrParts(5)
.isSet = True
End With
Case Else
Exit Do
End Select
Loop
Close #fileNumber
On Error GoTo 0
End Sub
Private Function GetProviderIndexByURL(ByRef providers As OneDriveProviders _
, ByVal partURL As String) As Long
Dim i As Long
For i = 1 To providers.pCount
With providers.arr(i)
If .isBusiness And Not .isSet Then
If StrComp(Left$(.urlNamespace, Len(partURL)), partURL, vbTextCompare) = 0 Then
GetProviderIndexByURL = i
Exit Function
End If
End If
End With
Next i
End Function
Private Function GetProviderIndexByPath(ByRef providers As OneDriveProviders _
, ByVal mountPath As String) As Long
Dim i As Long
For i = 1 To providers.pCount
With providers.arr(i)
If .isBusiness And Not .isSet Then
If StrComp(.mountPoint, mountPath, vbTextCompare) = 0 Then
GetProviderIndexByPath = i
Exit Function
End If
End If
End With
Next i
End FunctionThanks! |
|
Hello @cristianbuse |
|
Missed a detail in the The last test might still fail. That's because the Thanks! |
|
Sorry for the late reply, I wasn't home and had no access to my PC. I have no time at the moment to read and understand all your code but if you use the It seems like the feature of working on folders that don't exist is just fundamentally impossible as the function must check the actual file structure to determine at what level the server path is mounted. Also, I added another particularly difficult test case, that even my function fails, even if the file does exist: TestGetLocalPath "Test4 Private SharePoint shared by someone else (third level folder mount with particularly tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1)\Test\test.xlsm"Results with your solution: If you have other ideas for interesting or tricky test cases involving SharePoint or anything you don't have access to, let me know. Though I'd also understand if you just don't care about these rare and constructed edge cases... |
|
Hi @guwidoe , Actually I am very interested in the edge cases and very grateful that you are so helpful. Would you be able to check if there is a Thanks! |
|
That's good to know :) Here is my registry for the folders in question: Another interesting thing I just noticed is, that in case of OneDrive for Business, there is no RelativePath Key, but in the cases where the synchronized folder is not at the bottom of the server folder hierarchy, there exists another key called |
|
I just added another test, that is by far the hardest one so far in my opinion: TestGetLocalPath "Test6 Private SharePoint shared by someone else (fourth level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (1)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\FourthLevel\Test (1)\Test\test.xlsm"I have no idea how any solution could possibly pass both of the last two tests, it seems completely impossible. EDIT: I think I just came up with a solution in my head, it only works for existing files but it should theoretically be possible. I'll post it here as soon as I translated it into code... |
|
I just added two more test cases that might give some more hints as to how we can solve it for the general case: TestGetLocalPath "Test7 Private SharePoint shared by someone else (third level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (2)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1) (1)\FourthLevel\Test (1)\Test\test.xlsm"
TestGetLocalPath "Test8 Private SharePoint shared by someone else (second level folder mount with tricky name)", _
"https://d.docs.live.net/733ae81c3aefa499/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (2)\Test\test.xlsm"If you synchronize a folder with the actual name If you synchronize a folder called Edit: Also the I wonder if converting it like this is sufficient: If InStr(1, strCid, "!") Then: _
strCid = LCase(left(strCid, InStr(1, strCid, "!") - 1)) |
|
Hello @cristianbuse I just found where the information we need for those convoluted paths is stored.
For me the contents look like this: The numbers at the end of these Uri's are exactly the weird |
|
Hi @guwidoe , This is excellent. I can see the file in my folder as well. I am really annoyed because 2 days ago I indexed all the files in the settings folder and used windows search to search for the specific folder name (e.g. Test) inside file contents. Window Search did not find anything and so I did not open each file to search manually. What a useless tool. I can see the name I searched for in the GroupFolders.ini when I open it but search does not find it. Indeed this find removes the ambiguity and the guessing. Well done! Won't have time today but will definitely write a new function tomorrow to incorporate your find. Thanks! |
|
Hello @guwidoe , Below is the updated code. Option Explicit
Private Type OneDriveProvider
cID As String
urlNamespace As String
mountPoint As String
actualFolder As String
isSet As Boolean
isBusiness As Boolean
End Type
Private Type OneDriveProviders
arr() As OneDriveProvider
pCount As Long
isSet As Boolean
End Type
Private Enum ProviderFindType
tCID
tMount
tURL
End Enum
'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
'
Static providers As OneDriveProviders
Dim i As Long
Dim tempURL As String
'
If Not providers.isSet Then providers = GetOneDriveProviders()
'
For i = 1 To providers.pCount
With providers.arr(i)
tempURL = Left$(odWebPath, Len(.urlNamespace))
If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
End With
Next i
If i > providers.pCount Then Exit Function
'
Dim rPart As String
Dim tempPart As String
Dim p As Long
Dim tempActual As String
Dim multiOccurence As Boolean
'
With providers.arr(i)
rPart = Replace(odWebPath, .urlNamespace, vbNullString)
If Not .isSet Then
tempActual = "/" & .actualFolder & "/"
p = InStr(1, rPart, tempActual, vbTextCompare)
If p = 0 Then Exit Function
'
multiOccurence = (InStr(p + 1, rPart, tempActual, vbTextCompare) > 0)
tempPart = Mid$(rPart, p + Len(tempActual) - 1)
'
If multiOccurence Then
Do Until LenB(Dir(BuildPath(.mountPoint, tempPart), vbDirectory)) > 0
p = InStr(p + 1, rPart, tempActual, vbTextCompare)
If p = 0 Then Exit Do
tempPart = Mid$(rPart, p + Len(tempActual) - 1)
Loop
End If
rPart = tempPart
End If
GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
End With
End Function
'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
Const computerName As String = "."
Dim oReg As Object
Dim subKeys() As Variant
Dim subKey As Variant
Dim i As Long
'
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
& computerName & "\root\default:StdRegProv")
oReg.EnumKey HKCU, regPath, subKeys
'
With GetOneDriveProviders
On Error Resume Next
.pCount = UBound(subKeys) - LBound(subKeys) + 1
On Error GoTo 0
If .pCount = 0 Then Exit Function
'
ReDim .arr(1 To .pCount)
i = 1
For Each subKey In subKeys
ReadRegistryProvider oReg, regPath & subKey, .arr(i)
i = i + 1
Next subKey
FixProvidersFromSettings .arr
.isSet = True
End With
End Function
'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
, ByVal regKey As String _
, ByRef provider As OneDriveProvider)
Const HKCU = &H80000001
Dim cID As String
Dim aFolder As String
Dim relPath As String
'
With provider
oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
oReg.GetStringValue HKCU, regKey, "CID", cID
.cID = FixCID(cID)
.isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
If .isBusiness Then
If Right$(.urlNamespace, 1) = "/" Then
.urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
End If
Else
oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
.urlNamespace = .urlNamespace & "/" & .cID
If LenB(relPath) = 0 Then
.isSet = True
Else
.mountPoint = BuildPath(.mountPoint, relPath)
End If
End If
End With
End Function
Private Function FixCID(ByVal cID As String) As String
Dim i As Long: i = InStr(1, cID, "!")
If i = 0 Then FixCID = cID Else FixCID = Left$(cID, i - 1)
End Function
'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
Const businessIniMask As String = "????????-????-????-????-????????????.ini"
Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
Dim settingsPath As String
Dim folderPath As Variant
Dim folderName As String
Dim iniName As String
Dim iniPath As String
'
settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
For Each folderPath In GetFolders(settingsPath)
folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
If folderName Like "Business*" Then
iniName = Dir(BuildPath(folderPath, businessIniMask))
If LenB(iniName) > 0 Then
iniPath = BuildPath(folderPath, iniName)
FixBusinessProviders iniPath, providers
End If
ElseIf folderName = "Personal" Then
iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
If IsFile(iniPath) Then
FixPersonalProviders iniPath, providers
End If
End If
Next folderPath
End Sub
'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal filePath As String _
, ByRef providers() As OneDriveProvider)
Dim fileNumber As Long: fileNumber = FreeFile
Dim lineText As String
Dim arrParts() As String
Dim tempMount As String
Dim tempURL As String
Dim i As Long
'
Open filePath For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
'
Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
Case "libraryScope"
arrParts = Split(lineText, """")
If UBound(arrParts) >= 9 Then
tempMount = arrParts(9)
If LenB(tempMount) > 0 Then
tempURL = arrParts(5)
Do
i = FindProvider(providers, tURL, tempURL)
If i > 0 Then providers(i).isSet = True
Loop Until i = 0
End If
End If
Case "libraryFolder"
arrParts = Split(lineText, """")
If UBound(arrParts) >= 3 Then
tempMount = arrParts(1)
i = FindProvider(providers, tMount, tempMount)
If i > 0 Then providers(i).actualFolder = arrParts(3)
End If
Case "AddedScope"
arrParts = Split(lineText, """")
If UBound(arrParts) >= 3 Then
tempURL = arrParts(1)
i = FindProvider(providers, tURL, tempURL)
If i > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & "/" & arrParts(5)
.isSet = True
End With
End If
End If
Case Else
Exit Do
End Select
Loop
Close #fileNumber
End Sub
'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindProvider(ByRef providers() As OneDriveProvider _
, ByVal findType As ProviderFindType _
, ByVal searchValue As String) As Long
Dim i As Long
Dim temp As String
For i = LBound(providers) To UBound(providers)
With providers(i)
If Not .isSet Then
Select Case findType
Case tCID: temp = .cID
Case tMount: temp = .mountPoint
Case tURL: temp = Left$(.urlNamespace, Len(searchValue))
End Select
If StrComp(temp, searchValue, vbTextCompare) = 0 Then
FindProvider = i
Exit Function
End If
End If
End With
Next i
End Function
'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal filePath As String _
, ByRef providers() As OneDriveProvider)
Dim fileNumber As Long: fileNumber = FreeFile
Dim lineText As String
Dim i As Long
Dim cID As String
Dim relPath As String
'
Open filePath For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
'
i = InStr(1, lineText, "_")
If i > 0 Then
i = i + 1
Select Case Mid$(lineText, i, InStr(i, lineText, " ") - i)
Case "BaseUri"
cID = FixCID(Mid$(lineText, InStrRev(lineText, "/") + 1))
Case "Path"
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
i = FindProvider(providers, tCID, cID)
If i > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & "/" & relPath
.isSet = True
End With
End If
End Select
End If
Loop
Close #fileNumber
End Sub |
|
Hello @cristianbuse Unfortunately, there are still some problems. :( For a little speculation why please read the end of my post! I updated my tests multiple times, so I'll post them all again here for clarity. TestGetLocalPath "Test Company SharePoint", _
"https://abconline.sharepoint.com/sites/ACEA/Freigegebene Dokumente/General/2021/04_Working/- Archiv -/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\ACEA - General\2021\04_Working\- Archiv -\test.xlsm"
TestGetLocalPath "Test2 Company SharePoint", _
"https://abconline.sharepoint.com/sites/AI/Freigegebene Dokumente/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\AI - Dokumente\Test\test.xlsm"
TestGetLocalPath "Test3 Company SharePoint, (file that doesn't exist, but in top lvl directory)", _
"https://abconline.sharepoint.com/sites/workspaces/ntbas/Shared Documents/Test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\NTB After Sales - Documents\Test.xlsm"
TestGetLocalPath "Test4 Company SharePoint", _
"https://abconline.sharepoint.com/sites/workspaces/NTB/Shared Documents/100_Business Development/", _
"C:\Users\Witt-DörringGuidoABC\ABC\NTB - Documents\100_Business Development\"
TestGetLocalPath "Test Personal Business OneDrive", _
"https://abconline-my.sharepoint.com/personal/gwitt-doerring_abc_at/Documents/-Test-/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive - ABC\-Test-\test.xlsm"
TestGetLocalPath "Test Personal Business OneDrive shared by someone else (mounts to SharePoint on local sync!)", _
"https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Beispiel import.xlsm", _
"C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Beispiel import.xlsm"
TestGetLocalPath "Test Private OneDrive folder", _
"https://d.docs.live.net/f1189d8c9189d493/Testfolder_toplvl/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Testfolder_toplvl\test.xlsm"
TestGetLocalPath "Test2 Personal Business OneDrive shared by someone else (nonexistant folder)", _
"https://abconline-my.sharepoint.com/personal/operson_abc_at/Documents/Guido/Test/", _
"C:\Users\Witt-DörringGuidoABC\ABC\Person Other - Guido\Test\"
TestGetLocalPath "Test3 Private SharePoint shared by someone else (second level folder mount)", _
"https://d.docs.live.net/5cfc6adc55f2ae2b/FirstLevel/SecondLevel/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\SecondLevel\test.xlsm"
TestGetLocalPath "Test4 Private SharePoint shared by someone else (second level folder mount with tricky name)", _
"https://d.docs.live.net/5cfc6adc55f2ae2b/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test\Test\test.xlsm"
TestGetLocalPath "Test5 Private SharePoint shared by someone else (third level folder mount with particularly tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1)\Test\test.xlsm"
TestGetLocalPath "Test6 Private SharePoint shared by someone else (fourth level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (1)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\FourthLevel\Test (1)\Test\test.xlsm"
TestGetLocalPath "Test7 Private SharePoint shared by someone else (third level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (2)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1) (1)\FourthLevel\Test (1)\Test\test.xlsm"
TestGetLocalPath "Test8 Private SharePoint shared by someone else (third level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (3)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1) (2)\Test\test.xlsm"
TestGetLocalPath "Test9 Private SharePoint shared by someone else (third level folder mount with extremely tricky name)", _
"https://d.docs.live.net/3dea8a9886f05935/Test (4)/SecondLevel/Test (1)/FourthLevel/Test (1)/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (1) (3)\Test\test.xlsm"
TestGetLocalPath "Test10 Private SharePoint shared by someone else (second level folder mount with tricky name)", _
"https://d.docs.live.net/733ae81c3aefa499/Test/Test/Test/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Test (2)\Test\test.xlsm"
TestGetLocalPath "Test11 Private SharePoint (Business1 folder name because of supposed cunfusion in the registry, but the registry key just got overwritten)", _
"https://d.docs.live.net/3dea8a9886f05935/Business1/test.xlsm", _
"C:\Users\Witt-DörringGuidoABC\OneDrive\Business1\test.xlsm"The current results are as follows. I'm currently trying to write my own version of the function but as a self contained procedure without external dependencies or private types. In doing so I noticed another inconsistency between the Registry and the My The big problem is, that not all of the Refers to this folder: This cid from the registry is not even unique, for instance, the first entry of the file looks like this: And the registry looks like this: In fact. I can't find the For other folders, it looks like this should work just fine, for instance, this one: can easily be correlated using the registry: The only place I found these But I'm not yet sure how to read it correctly and if it even contains all the information we need. Another question I have for you: In the Business P.s. By the way I have the same problem with Windows Search, did you find a solution or some third-party software? |
|
I see. I wasn't expecting to have same CID for multiple providers. I did not see that on mine. I already looked into the .dat file using OneDriveExplorer (see last release) but it does not look to be useful and moreover the file is so big that it would take some time to parse. The The |
|
I now managed to write a function that passes all my tests, Private Function GetLocalPath(ByVal path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
Const HKEY_CURRENT_USER = &H80000001
Const computerName As String = "."
Static WebToLocDict As Object 'Scripting.Dictionary
If Not WebToLocDict Is Nothing And Not rebuildCache Then GoTo UseDict
Set WebToLocDict = Nothing
Set WebToLocDict = CreateObject("Scripting.Dictionary")
Dim objReg As Object
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
computerName & "\root\default:StdRegProv")
Dim regPath As String
regPath = "Software\SyncEngines\Providers\OneDrive\"
Dim subKeys() As Variant
objReg.EnumKey HKEY_CURRENT_USER, regPath, subKeys
Dim subKey As Variant
Dim cid As String
Dim relPath As String
Dim webRoot As String
Dim locRoot As String
For Each subKey In subKeys
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, _
"UrlNamespace", webRoot
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, "CID", cid
'InStr(cid, "-") = 0 to check if it's not a business cid
If cid <> "" And InStr(cid, "-") = 0 Then: _
webRoot = webRoot & "/" & LCase(cid)
If right(webRoot, 1) = "/" Then: _
webRoot = left(webRoot, Len(webRoot) - 1)
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, _
"MountPoint", locRoot
objReg.GetStringValue HKEY_CURRENT_USER, regPath & subKey, _
"RelativePath", relPath
If relPath <> "" Then: locRoot = locRoot & "\" & relPath
'Adding subKey to the dict is necessary because the constructed webRoot
'is not necessarily unique.
WebToLocDict(subKey & "\" & webRoot) = locRoot
Next
Dim dirName As String
Dim odSettPath As String
Dim odSettFile As String
Dim fileNumber As Long
Dim lineText As String
Dim lineParts() As String
Dim vWebRoot As Variant
Dim cidClean As String
Dim webMountDir As String
Dim residue As String
Dim i As Long
objReg.GetStringValue HKEY_CURRENT_USER, "Volatile Environment", _
"LOCALAPPDATA", odSettPath
regPath = "Software\Microsoft\OneDrive\Accounts\"
odSettPath = odSettPath & "\Microsoft\OneDrive\settings\"
dirName = Dir(odSettPath, vbDirectory)
Do Until dirName = ""
Select Case True
Case dirName Like "Business#"
objReg.GetStringValue HKEY_CURRENT_USER, regPath & dirName, _
"cid", cid
If cid <> "" Then
odSettFile = odSettPath & dirName & "\" & cid & ".ini"
fileNumber = FreeFile
Open odSettFile For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
Select Case left$(lineText, InStr(lineText, " = ") - 1)
Case "libraryScope"
'No change to dict necessary
Case "libraryFolder"
lineParts = Split(lineText, """")
For Each vWebRoot In WebToLocDict.Keys
If WebToLocDict(vWebRoot) = lineParts(1) Then
WebToLocDict.Add key:=vWebRoot & "/" & _
lineParts(3), _
Item:=WebToLocDict(vWebRoot)
WebToLocDict.Remove vWebRoot
Exit For
End If
Next vWebRoot
Case "AddedScope"
lineParts = Split(lineText, """")
For Each vWebRoot In WebToLocDict.Keys
webRoot = Mid(vWebRoot, InStr(vWebRoot, "\") + 1)
If InStr(1, webRoot, lineParts(1), _
vbBinaryCompare) = 1 Then
WebToLocDict.Add key:=vWebRoot & "/" & _
lineParts(5), _
Item:=WebToLocDict(vWebRoot)
WebToLocDict.Remove vWebRoot
Exit For
End If
Next vWebRoot
Case Else
Exit Do
End Select
Loop
Close #fileNumber
End If
Case dirName = "Personal"
cid = ""
odSettFile = odSettPath & dirName & "\GroupFolders.ini"
fileNumber = FreeFile
Open odSettFile For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
If InStr(lineText, "aseUri = https://") And cid = "" Then
cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1))
cidClean = left(cid, InStr(cid, "!") - 1)
ElseIf cid <> "" Then
For i = UBound(WebToLocDict.Keys) To 0 Step -1
vWebRoot = WebToLocDict.Keys()(i)
locRoot = WebToLocDict(vWebRoot)
webRoot = Mid(vWebRoot, InStr(vWebRoot, "\") + 1)
subKey = left(vWebRoot, InStr(vWebRoot, "\"))
If right(webRoot, Len(cid)) = cid Then
WebToLocDict.Add _
key:=subKey & _
left(webRoot, InStrRev(webRoot, "/")) & _
left(cid, InStr(1, cid, "!") - 1) & "/" & _
Mid(lineText, InStr(lineText, " = ") + 3), _
Item:=locRoot
WebToLocDict.Remove vWebRoot
Exit For
'This ElseIf is necessary because the cid's from the
'registry are unfortunately not necssarily unique
ElseIf Mid(webRoot, InStrRev(webRoot, "/") + 1) = _
cidClean Then
relPath = _
Mid(locRoot, InStrRev(locRoot, "\") + 1)
webMountDir = _
Mid(lineText, InStr(lineText, " = ") + 3)
webMountDir = _
Mid(webMountDir, InStrRev(webMountDir, "/") + 1)
residue = Replace(relPath, webMountDir, "", , 1)
'The " (#)" are necessary in case two or more
'folders with the same name are synchronized.
'In OneDrive, a folder contains max 50000 items.
If residue = "" Or _
residue Like " (#)" Or _
residue Like " (##)" Or _
residue Like " (###)" Or _
residue Like " (####)" Or _
residue Like " (#####)" Then
WebToLocDict.Add _
key:=subKey & webRoot & "/" & _
Mid(lineText, _
InStr(lineText, " = ") + 3), _
Item:=locRoot
WebToLocDict.Remove vWebRoot
Exit For
End If
End If
Next i
cid = ""
End If
Loop
Close #fileNumber
Case Else
End Select
dirName = Dir
Loop
UseDict:
For Each vWebRoot In WebToLocDict.Keys
webRoot = Mid(vWebRoot, InStr(vWebRoot, "\") + 1)
If InStr(1, path, webRoot, vbBinaryCompare) Then
path = Replace(path, webRoot, WebToLocDict(vWebRoot))
GetLocalPath = Replace(path, "/", "\")
Exit Function
End If
Next vWebRoot
End FunctionThe only part which is a little bit dodgy is the following: ElseIf cid <> "" Then
For i = UBound(WebToLocDict.Keys) To 0 Step -1
vWebRoot = WebToLocDict.Keys()(i)
locRoot = WebToLocDict(vWebRoot)
webRoot = Mid(vWebRoot, InStr(vWebRoot, "\") + 1)
subKey = left(vWebRoot, InStr(vWebRoot, "\"))
If right(webRoot, Len(cid)) = cid Then
WebToLocDict.Add _
key:=subKey & _
left(webRoot, InStrRev(webRoot, "/")) & _
left(cid, InStr(1, cid, "!") - 1) & "/" & _
Mid(lineText, InStr(lineText, " = ") + 3), _
Item:=locRoot
WebToLocDict.Remove vWebRoot
Exit For
'This ElseIf is necessary because the cid's from the
'registry are unfortunately not necssarily unique
ElseIf Mid(webRoot, InStrRev(webRoot, "/") + 1) = _
cidClean Then
relPath = _
Mid(locRoot, InStrRev(locRoot, "\") + 1)
webMountDir = _
Mid(lineText, InStr(lineText, " = ") + 3)
webMountDir = _
Mid(webMountDir, InStrRev(webMountDir, "/") + 1)
residue = Replace(relPath, webMountDir, "", , 1)
'The " (#)" are necessary in case two or more
'folders with the same name are synchronized.
'In OneDrive, a folder contains max 50000 items.
If residue = "" Or _
residue Like " (#)" Or _
residue Like " (##)" Or _
residue Like " (###)" Or _
residue Like " (####)" Or _
residue Like " (#####)" Then
WebToLocDict.Add _
key:=subKey & webRoot & "/" & _
Mid(lineText, _
InStr(lineText, " = ") + 3), _
Item:=locRoot
WebToLocDict.Remove vWebRoot
Exit For
End If
End If
Next i
cid = ""
End If
I don't quite understand how OneDrive works with the registry and why it didn't provide a unique |
|
Thanks for this! Will only be able to test on Monday. Will get back to you then |
|
Hi @guwidoe , Just ran my tests with your newest function and 4 out of 12 tests fail. All 4 are shared folders from other colleagues business OneDrive. I am swamped today/tomorrow but my hope is that this week I can look into your function logic and see if I can combine with mine and get something that passes both our tests. Many thanks! |
|
Hi @cristianbuse, I just wanted to let you know I'm working on a solution now. I will update this post as I go and share my finds with you and eventually post a function that (hopefully) will pass all my tests. I've now been working on extracting the folders from the I found the culprit! See my next comment |
I think I may finally have a solution!IT WASN'T OUR CODE, IT WAS MY TEST THAT WAS WRONG! My colleague who shared the folder I synced for this test scenario must have moved it inside of his personal OneDrive and it seems like he added two layers of "Guido" folders! I'm very sorry for not figuring that out sooner! I have now updated the tests and now your function passes these annoying two tests without issues. There are some others, though, which it still fails on: One of the tests that your current solution fails is a new one I came up with. I synchronized a folder called "Personal" shared by someone else's private OneDrive onto my private OneDrive. This can mess the Registry up a little bit. Maybe this screenshot of my registry has some value for you: This is my function, it passes all my tests. Please let me know if it also passes all your tests! Public Function GetLocalPath(ByVal Path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
GetLocalPath = Path
Exit Function
#End If
Dim webRoot As String
Dim vKey As Variant
Static WebToLocDict As Object
If Not WebToLocDict Is Nothing And Not rebuildCache Then
For Each vKey In WebToLocDict.Keys
If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
GetLocalPath = Replace(Path, "/", "\")
Exit Function
End If
Next vKey
GetLocalPath = Path
Exit Function
End If
Const HKCU = &H80000001
Const computerName As String = "."
Dim objReg As Object
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
computerName & "\root\default:StdRegProv")
Dim regPath As String
regPath = "Software\SyncEngines\Providers\OneDrive\"
Dim LocToWebDict As Object
Set LocToWebDict = CreateObject("Scripting.Dictionary")
Dim cid As String
Dim libType As String
Dim locRoot As String
Dim subKeys() As Variant
Dim subKey As Variant
'Initializing the dict from the registry:
objReg.EnumKey HKCU, regPath, subKeys
'First add all the Business OneDrive MountPoints
For Each subKey In subKeys
objReg.GetStringValue HKCU, regPath & subKey, "UrlNamespace", webRoot
objReg.GetStringValue HKCU, regPath & subKey, "MountPoint", locRoot
objReg.GetStringValue HKCU, regPath & subKey, "CID", cid
objReg.GetStringValue HKCU, regPath & subKey, "LibraryType", libType
'NOTE: For personal OneDrive folders, this way of adding the MountPoints
'is too risky. There can be various reasons why these registry keys
'can contain mistakes, like:
'1. Synchronizing a folder called "Personal" from someone elses personal
' OneDrive
'2. Synchronizing a folder called "Business1" from someone elses personal
' OneDrive and then relogging your own first Business OneDrive
'3. Relogging you own personal OneDrive can change the "CID" property
' from a folderID formatted cid (e.g. 3DEA8A9886F05935!125) to a
' regular private cid (e.g. 3dea8a9886f05935) for synced folders
' from other people's OneDrives
If libType <> "personal" Then LocToWebDict(locRoot) = webRoot
Next subKey
Dim fileNumber As Long
Dim lineText As String
Dim lineParts() As String
Dim bytes() As Byte
Dim byteStr As String: byteStr = ""
Dim datFileFolders As Object
Dim pos As Long, str As String
Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
Dim parentID As String, folderID As String, folderName As String
Dim lenFolderName As Long
Dim dirName As String
Dim settPath As String
objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
settPath = settPath & "\Microsoft\OneDrive\settings\"
regPath = "Software\Microsoft\OneDrive\Accounts\"
Dim PersGroupFoldersIniExists As Boolean: PersGroupFoldersIniExists = _
(Dir(settPath & "Personal\GroupFolders.ini") <> "")
'Refining the dict using the relevant .ini files in the OneDrive settings:
dirName = Dir(settPath, vbDirectory)
Do Until dirName = ""
Select Case True
'At most, 9 Business OneDrive accounts can be signed in at once.
Case dirName Like "Business#"
objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
If cid = "" Then GoTo NextFolder
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".dat" For _
Binary Access Read As #fileNumber
ReDim bytes(0 To LOF(fileNumber) - 1)
Get fileNumber, , bytes: byteStr = bytes
Close #fileNumber: fileNumber = 0
Set datFileFolders = CreateObject("Scripting.Dictionary")
pos = InStrB(1, byteStr, sig1)
Do Until pos = 0
If InStrB(pos, byteStr, sig2) - pos = 16 Then
folderID = StrConv(MidB(byteStr, pos + 24, 32), vbUnicode)
parentID = StrConv(MidB(byteStr, pos + 63, 32), vbUnicode)
lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
vbNullChar) - (pos + 184)) / 2) * 2
folderName = MidB(byteStr, pos + 184, lenFolderName)
If folderID Like "[a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9][a-f0-9]" Then
datFileFolders.Add Key:=folderID, _
Item:=Array(parentID, folderName)
End If
End If
pos = InStrB(pos + 1, byteStr, sig1)
Loop
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".ini" For _
Input Access Read As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
Select Case left$(lineText, InStr(lineText, " = ") - 1)
Case "libraryScope"
'No change to dict necessary
Case "libraryFolder"
locRoot = Split(lineText, """")(1)
parentID = left(Split(lineText, " ")(4), 32)
For Each vKey In LocToWebDict.Keys
If vKey = locRoot Then
Do Until Not datFileFolders.Exists(parentID)
str = datFileFolders(parentID)(1) & "/" & str
parentID = datFileFolders(parentID)(0)
Loop
LocToWebDict(vKey) = LocToWebDict(vKey) & str
str = ""
Exit For
End If
Next vKey
Case "AddedScope"
lineParts = Split(lineText, """")
For Each vKey In LocToWebDict.Keys
webRoot = LocToWebDict(vKey)
If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
datFileFolders(left(Split(lineText, " ")(3), 32))(1) Then
LocToWebDict(vKey) = LocToWebDict(vKey) & _
lineParts(5)
Exit For
End If
Next vKey
Case Else
Exit Do
End Select
Loop
Close #fileNumber: fileNumber = 0
On Error GoTo 0
'Only one Personal OneDrive account can be signed in at a time.
Case dirName = "Personal"
'Adding personal root folder to the translation dict before going
'into the settings files to finalize the translation dict
objReg.GetStringValue HKCU, "Software\SyncEngines\Providers\" & _
"OneDrive\Personal", "UrlNamespace", webRoot
objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
If cid = "" Then GoTo NextFolder
LocToWebDict(locRoot) = webRoot & "/" & cid
If Not PersGroupFoldersIniExists Then GoTo NextFolder
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".dat" For _
Binary Access Read As #fileNumber
ReDim bytes(0 To LOF(fileNumber) - 1)
Get fileNumber, , bytes: byteStr = bytes
Close #fileNumber: fileNumber = 0
Set datFileFolders = CreateObject("Scripting.Dictionary")
pos = InStrB(1, byteStr, sig1)
Do Until pos = 0
If InStrB(pos, byteStr, sig2) - pos = 16 Then
folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
vbUnicode), vbNullChar, "")
parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
vbUnicode), vbNullChar, "")
lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
vbNullChar) - (pos + 184)) / 2) * 2
folderName = MidB(byteStr, pos + 184, lenFolderName)
If folderID Like "[A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9][A-F0-9]![0-9][0-9][0-9]*" Then
datFileFolders.Add Key:=folderID, _
Item:=Array(parentID, folderName)
End If
End If
pos = InStrB(pos + 1, byteStr, sig1)
Loop
cid = ""
fileNumber = FreeFile
Open settPath & dirName & "\GroupFolders.ini" For _
Input Access Read As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
If InStr(lineText, "BaseUri = https://") And cid = "" Then
cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
folderID = left(lineText, InStr(lineText, "_") - 1)
ElseIf cid <> "" Then
LocToWebDict.Add Key:=locRoot & "\" & _
datFileFolders(folderID)(1), _
Item:=webRoot & "/" & cid & "/" & _
Replace(lineText, folderID & "_Path = ", "")
cid = "": folderID = ""
End If
Loop
Close #fileNumber: fileNumber = 0
On Error GoTo 0
Case Else
End Select
NextFolder:
byteStr = ""
Set datFileFolders = Nothing
dirName = Dir
Loop
Set WebToLocDict = Nothing
Set WebToLocDict = CreateObject("Scripting.Dictionary")
For Each vKey In LocToWebDict.Keys
locRoot = vKey
webRoot = LocToWebDict(vKey)
If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
WebToLocDict.Add Key:=webRoot, Item:=locRoot
Next vKey
GetLocalPath = GetLocalPath(Path, False)
Exit Function
CloseFile:
If fileNumber <> 0 Then: Close #fileNumber
If fileNumber <> 0 Then: Close #fileNumber
err.Raise err
End Function |
|
Hi @guwidoe , This is excellent news. It does pass all my tests as well. Thank you very much for all your help! I could not have done this without you. I will surely mention your name and link to this issue at the top of the function signature. While sometimes a long function is the way to go, in this case I would definitely split it up. In my view it is too difficult to maintain and hard to grasp for someone looking at it for the first time. While I do understand it works very well for you and it is more efficient due to less stack frames, I would like to make it easier to digest for any future users of this repository. Your function has a cyclomatic complexity of 21 and 7 nesting levels and so hard to grasp by most people. Moreover, I would like to use the cache to convert from local path to OneDrive path (as I already do in the repo, although clearly wrong as it is) and so the cache must sit outside of the 2 functions using the cache: Once I update the repository, I hope you can test it one more time to be sure I haven't messed anything up. Many thanks, |
|
Hi @guwidoe , Before I update the repository, I want to refactor my code. I will consider using a dictionary like you did (or 2 collections) and might skip reading the registry for the Personal providers. However, I want to be sure that I got what the issue was. I basically added a new section to the Option Explicit
Private Type OneDriveProvider
cid As String
urlNamespace As String
mountPoint As String
actualFolder As String
isSet As Boolean
isBusiness As Boolean
End Type
Private Type OneDriveProviders
arr() As OneDriveProvider
pCount As Long
isSet As Boolean
End Type
Private Enum ProviderFindType
tCID
tMount
tURL
End Enum
'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
'
Static providers As OneDriveProviders
Dim i As Long
Dim tempURL As String
Dim rPart As String
'
If Not providers.isSet Then providers = GetOneDriveProviders()
'
For i = 1 To providers.pCount
With providers.arr(i)
tempURL = Left$(odWebPath, Len(.urlNamespace))
If StrComp(tempURL, .urlNamespace, vbTextCompare) = 0 Then Exit For
End With
Next i
If i > providers.pCount Then Exit Function
'
With providers.arr(i)
If Not .isSet Then Exit Function
rPart = Replace(odWebPath, .urlNamespace, vbNullString)
GetOneDriveLocalPath = BuildPath(.mountPoint, rPart)
End With
End Function
'*******************************************************************************
'Returns all the OD providers using Win registry and OD settings files
'https://docs.microsoft.com/en-us/windows/win32/wmisdk/obtaining-registry-data
'*******************************************************************************
Private Function GetOneDriveProviders() As OneDriveProviders
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const regPath As String = "Software\SyncEngines\Providers\OneDrive\"
Const computerName As String = "."
Dim oReg As Object
Dim subKeys() As Variant
Dim subKey As Variant
Dim i As Long
Static extraPersonal As Boolean
'
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
& computerName & "\root\default:StdRegProv")
oReg.EnumKey HKCU, regPath, subKeys
'
With GetOneDriveProviders
On Error Resume Next
.pCount = UBound(subKeys) - LBound(subKeys) + 1
On Error GoTo 0
If .pCount = 0 Then Exit Function
'
ReDim .arr(1 To .pCount)
i = 1
For Each subKey In subKeys
ReadRegistryProvider oReg, regPath & subKey, .arr(i)
If .arr(i).actualFolder = "Personal" And Not .arr(i).isBusiness And Not extraPersonal Then
Dim n As Long: n = .pCount + 1
Const regKey = "Software\Microsoft\OneDrive\Accounts\Personal"
'
ReDim Preserve .arr(1 To n)
oReg.GetStringValue HKCU, regKey, "cid", .arr(n).cid
oReg.GetStringValue HKCU, regKey, "UserFolder", .arr(n).mountPoint
.arr(n).urlNamespace = Replace(.arr(i).urlNamespace, .arr(i).cid, .arr(n).cid)
.arr(n).isSet = True
extraPersonal = True
End If
i = i + 1
Next subKey
FixProvidersFromSettings .arr
.isSet = True
End With
End Function
'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Function ReadRegistryProvider(ByVal oReg As Object _
, ByVal regKey As String _
, ByRef provider As OneDriveProvider)
Const HKCU = &H80000001
Dim cid As String
Dim aFolder As String
Dim relPath As String
'
With provider
oReg.GetStringValue HKCU, regKey, "UrlNamespace", .urlNamespace
oReg.GetStringValue HKCU, regKey, "MountPoint", .mountPoint
oReg.GetStringValue HKCU, regKey, "CID", cid
.cid = FixCID(cid)
.isBusiness = Not (.urlNamespace = "https://d.docs.live.net")
If .isBusiness Then
If Right$(.urlNamespace, 1) = "/" Then
.urlNamespace = Left$(.urlNamespace, Len(.urlNamespace) - 1)
End If
Else
oReg.GetStringValue HKCU, regKey, "RelativePath", relPath
.urlNamespace = .urlNamespace & "/" & .cid
If LenB(relPath) = 0 Then
.isSet = True
Else
.actualFolder = relPath
.mountPoint = BuildPath(.mountPoint, relPath)
End If
End If
End With
End Function
Private Function FixCID(ByVal cid As String) As String
Dim i As Long: i = InStr(1, cid, "!")
If i = 0 Then FixCID = cid Else FixCID = Left$(cid, i - 1)
End Function
'*******************************************************************************
'Utility for 'GetOneDriveProviders'
'*******************************************************************************
Private Sub FixProvidersFromSettings(ByRef providers() As OneDriveProvider)
Const businessIniMask As String = "????????-????-????-????-????????????.ini"
Const personalDatMask As String = "????????????????.dat"
Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
Dim settingsPath As String
Dim folderPath As Variant
Dim folderName As String
Dim iniName As String
Dim iniPath As String
Dim datName As String
Dim datPath As String
'
settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
For Each folderPath In GetFolders(settingsPath)
folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
If folderName Like "Business*" Then
iniName = Dir(BuildPath(folderPath, businessIniMask))
If LenB(iniName) > 0 Then
iniPath = BuildPath(folderPath, iniName)
datPath = Replace(iniPath, ".ini", ".dat")
FixBusinessProviders iniPath, datPath, providers
End If
ElseIf folderName = "Personal" Then
iniPath = BuildPath(settingsPath, "Personal\GroupFolders.ini")
datName = Dir(BuildPath(folderPath, personalDatMask))
If LenB(datName) > 0 And IsFile(iniPath) Then
datPath = BuildPath(folderPath, datName)
FixPersonalProviders iniPath, datPath, providers
End If
End If
Next folderPath
End Sub
'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixBusinessProviders(ByVal iniPath As String _
, ByVal datPath As String _
, ByRef providers() As OneDriveProvider)
Dim fileNumber As Long: fileNumber = FreeFile
Dim lineText As String
Dim arrParts() As String
Dim tempMount As String
Dim tempID As String
Dim prevID As String
Dim tempFolder As String
Dim tempURL As String
Dim i As Long
Dim collFolders As Collection
Dim collParents As Collection
'
Open iniPath For Input Access Read As #fileNumber
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
'
Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
Case "libraryScope"
arrParts = Split(lineText, """")
If UBound(arrParts) >= 9 Then
tempMount = arrParts(9)
If LenB(tempMount) > 0 Then
tempURL = arrParts(5)
Do
i = FindBusinessProvider(providers, tURL, tempURL)
If i > 0 Then providers(i).isSet = True
Loop Until i = 0
End If
End If
Case "libraryFolder"
If collFolders Is Nothing Then
Set collFolders = GetODFolders(datPath, collParents)
End If
arrParts = Split(lineText, """")
tempMount = arrParts(1)
i = FindBusinessProvider(providers, tMount, tempMount)
If i > 0 Then
tempID = Split(arrParts(0), " ")(4)
tempID = Split(tempID, "+")(0)
tempFolder = vbNullString
On Error Resume Next
Do
tempFolder = "/" & collFolders(tempID) & tempFolder
prevID = tempID
tempID = collParents(tempID)
Loop Until Err.Number <> 0 Or prevID = tempID
On Error GoTo 0
If LenB(tempFolder) > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & tempFolder
.isSet = True
End With
End If
End If
Case "AddedScope"
arrParts = Split(lineText, """")
If UBound(arrParts) >= 3 Then
tempURL = arrParts(1)
i = FindBusinessProvider(providers, tURL, tempURL)
If i > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & "/" & arrParts(5)
.isSet = True
End With
End If
End If
Case Else
Exit Do
End Select
Loop
Close #fileNumber
End Sub
'*******************************************************************************
'Utility for finding a provider that is not set
'*******************************************************************************
Private Function FindBusinessProvider(ByRef providers() As OneDriveProvider _
, ByVal findType As ProviderFindType _
, ByVal searchValue As String) As Long
Dim i As Long
Dim temp As String
For i = LBound(providers) To UBound(providers)
With providers(i)
If Not .isSet And .isBusiness Then
Select Case findType
Case tCID: temp = .cid
Case tMount: temp = .mountPoint
Case tURL: temp = Left$(.urlNamespace, Len(searchValue))
End Select
If StrComp(temp, searchValue, vbTextCompare) = 0 Then
FindBusinessProvider = i
Exit Function
End If
End If
End With
Next i
End Function
'*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
, ByVal datPath As String _
, ByRef providers() As OneDriveProvider)
Dim s As String: s = ReadBytes(iniPath)
If LenB(s) = 0 Then Exit Sub
'
Dim lines() As String: lines = Split(s, vbNewLine)
Dim lineText As Variant
Dim i As Long
Dim cid As String
Dim relPath As String
Dim folderID As String
Dim folderName As String
Dim collFolders As Collection
'
For Each lineText In lines
i = InStr(1, lineText, "_")
If i > 0 Then
Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
Case "BaseUri"
cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
Case "Path"
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
folderID = Left$(lineText, i - 1)
If collFolders Is Nothing Then
Set collFolders = GetODFolders(datPath)
End If
If collFolders.Count > 0 Then
folderName = collFolders(folderID)
i = FindPersonalProvider(providers, cid, folderName)
If i > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & "/" & relPath
.isSet = True
End With
End If
End If
End Select
End If
Next lineText
End Sub
'*******************************************************************************
'Utility for finding a business provider that is not set
'*******************************************************************************
Private Function FindPersonalProvider(ByRef providers() As OneDriveProvider _
, ByRef cid As String _
, ByVal actualFolder As String) As Long
Dim fCID As String: fCID = FixCID(cid)
Dim i As Long
For i = LBound(providers) To UBound(providers)
With providers(i)
If Not .isSet And Not .isBusiness Then
If StrComp(.actualFolder, actualFolder, vbTextCompare) = 0 Then
If StrComp(.cid, cid, vbTextCompare) = 0 _
Or StrComp(.cid, fCID, vbTextCompare) = 0 Then
FindPersonalProvider = i
Exit Function
End If
End If
End If
End With
Next i
End Function
'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
, Optional ByRef outParents As Collection) As Collection
Dim s As String: s = ReadBytes(filePath)
Dim size As Long: size = LenB(s)
If size = 0 Then Exit Function
'
Dim hFolder As String
Dim hCheck As String
Dim i As Long
Dim v As Variant
Dim stepSize As Long
Dim bytes As Long
Dim folderID As String
Dim parentID As String
Dim folderName As String
Dim collFolders As New Collection
Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
'
hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
If outParents Is Nothing Then Set outParents = New Collection
'
For Each v In Array(16, 8)
stepSize = v
i = InStrB(stepSize, s, hCheck)
Do While i > stepSize And i < size - 168
If MidB$(s, i - stepSize, 1) = hFolder Then
i = i + 8
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 39
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 121
bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
If bytes < 0 Then bytes = 0
folderName = MidB$(s, i, bytes)
'
If LenB(folderID) > 0 And LenB(parentID) > 0 Then
collFolders.Add folderName, folderID
outParents.Add parentID, folderID
End If
End If
i = InStrB(i + 1, s, hCheck)
Loop
If collFolders.Count > 0 Then Exit For
Next v
Set GetODFolders = collFolders
End Function
'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Function ReadBytes(ByVal filePath As String) As Byte()
Dim fileNumber As Long: fileNumber = FreeFile
Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
'
Open filePath For Binary Access Read As #fileNumber
ReDim ReadBytes(0 To LOF(fileNumber) - 1)
Get fileNumber, , ReadBytes
Close #fileNumber
'
If mustDelete Then DeleteFile filePath
End Function |
I 100% agree with you. In addition to this, it has some duplicate code that would be much easier to avoid using multiple routines. It was never meant to replace your much more elegant approach of an interconnected library solving many problems at once. The reason for me trying so hard to do this in a single function is a little bit of an emotional one, and I wasn't aiming to write the most readable code. Let me try to explain. As you can see, there doesn't exist a single solution out there (apart from ours) that comes even remotely close to being reliable. In fact, the best other solution passes 9/32 Tests. In case you are wondering what my ''Ultra-short solution written by Guido Witt-Dörring
Public Function GetLocalPath(ByVal f As String) As String
Const H = &H80000001
Dim o As Object, r As String, s(), k, u As String, m As String, p As String
Set o = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
r = "Software\SyncEngines\Providers\OneDrive\": o.EnumKey H, r, s
For Each k In s
o.GetStringValue H, r & k, "UrlNamespace", u
If InStr(f, u) > 0 Then
o.GetStringValue H, r & k, "MountPoint", m
p = Replace(Mid(f, Len(u)), "/", "\"): f = m & p
Do Until Dir(f, 16) <> "" Or InStr(2, p, "\") = 0
p = Mid(p, InStr(2, p, "\")): f = m & p
Loop
Exit For
End If
Next
GetLocalPath = f
End FunctionI must say I'm quite proud of this, as it obliterates any other solution I could find online in terms of accuracy in just 15 lines of code. Even without the "obfuscated" variable names, it's still very, very short: 'Short solution written by Guido Witt-Dörring
Public Function GetLocalPath(ByVal Path As String) As String
Const HKCU = &H80000001
Dim objReg As Object, rPath As String, subKeys(), subKey
Dim urlNamespace As String, mountPoint As String, secPart As String
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
rPath = "Software\SyncEngines\Providers\OneDrive\"
objReg.EnumKey HKCU, rPath, subKeys
For Each subKey In subKeys
objReg.GetStringValue HKCU, rPath & subKey, "UrlNamespace", urlNamespace
If InStr(Path, urlNamespace) > 0 Then
objReg.GetStringValue HKCU, rPath & subKey, "MountPoint", mountPoint
secPart = Replace(Mid(Path, Len(urlNamespace)), "/", "\")
Path = mountPoint & secPart
Do Until Dir(Path, vbDirectory) <> "" Or InStr(2, secPart, "\") = 0
secPart = Mid(secPart, InStr(2, secPart, "\"))
Path = mountPoint & secPart
Loop
Exit For
End If
Next
GetLocalPath = Path
End FunctionThis "Short solution" is the one I currently use when I actually need a Back to the reason why I tried to write everything into a single function: If I try to condense your library down to just contain the necessary elements for the GetLocalPath Function, I have about 680 lines of code, including some Private Types that pretty much only make it portable as a separate module. But realistically, If someone would want to use your solution, they'd have to use the whole library, because cherry-picking this one thing out of your library is way too much work. In most cases, this is just overkill because as I said, this often occurs as an isolated problem. Maybe I'll split it up into more routines in the future, or maybe I'll just try to condense the function as a whole.
My function does cache the
This is very kind and much appreciated, thank you! |
I just tested your updated code, it still fails the same three tests. If you have an idea how I can help you debug (registry screenshots, breakpoints in the code etc.) please let me know. I'm happy to help! |
|
Thanks @guwidoe for the explanation!
I completely understand this. And I think you should definitely post back on Stack Overflow once you remove some of the duplication. However, this repository has a few useful/indispensable functions (like
I want 2 separate publicly exposed functions to access the same cache and so the cache cannot be defined in any one of them. It must either be module level or declared as Static inside a 3rd private function that is called by both the public functions. In the current form of the module there is a
Could you please check if the |
I see, this explains it of course!
Oh, I have never even considered this! That's cool! It's much less important for me because
I tested the requested line as follows: '*******************************************************************************
'Utility for 'FixProvidersFromSettings'
'*******************************************************************************
Private Sub FixPersonalProviders(ByVal iniPath As String _
, ByVal datPath As String _
, ByRef providers() As OneDriveProvider)
Dim s As String: s = ReadBytes(iniPath)
If LenB(s) = 0 Then Exit Sub
'
Dim lines() As String: lines = Split(s, vbNewLine)
Dim lineText As Variant
Dim i As Long
Dim cid As String
Dim relPath As String
Dim folderID As String
Dim folderName As String
Dim collFolders As Collection
Dim gwdDict As Object
Set gwdDict = PersonalFoldersDict
For Each lineText In lines
i = InStr(1, lineText, "_")
If i > 0 Then
Select Case Mid$(lineText, i + 1, InStr(i, lineText, " ") - i - 1)
Case "BaseUri"
cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
Case "Path"
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
folderID = left$(lineText, i - 1)
If collFolders Is Nothing Then
Set collFolders = GetODFolders(datPath)
End If
If collFolders.count > 0 Then
folderName = collFolders(folderID)
If folderName <> gwdDict(folderID)(1) Then
Debug.Print "error"
End If
i = FindPersonalProvider(providers, cid, folderName)
Debug.Print i
If i > 0 Then
With providers(i)
.urlNamespace = .urlNamespace & "/" & relPath
.isSet = True
Debug.Print .urlNamespace, cid, folderName
End With
End If
End If
End Select
End If
Next lineText
End Sub
|
|
Cool. It seems the very last one is a 0 so that's the issue. Could you replace this: Debug.Print iwith this: If i = 0 Then
Debug.Print cid, folderName
Stop
End Ifand then check in the
Thanks! |
|
Indeed I found a folder that has the
I think that is because depending on which of these two events happened last, there can be different
Because of this confusion, I stopped using the registry for personal OneDrive. |
|
@guwidoe , Thanks! Indeed I need to stop using the registry for personal OneDrive. At least now I know that is the only issue. |
|
I refactored my code down to this 200 line monstrosity: Public Function GetLocalPath(ByVal Path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
GetLocalPath = Path: Exit Function
#End If
Const HKCU = &H80000001
Const computerName As String = "."
Dim webRoot As String, vKey As Variant, i As Long
Static WebToLocDict As Object
If Not WebToLocDict Is Nothing And Not rebuildCache Then
For Each vKey In WebToLocDict.Keys
If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
GetLocalPath = Replace(Path, "/", "\"): Exit Function
End If
Next vKey
GetLocalPath = Path: Exit Function
End If
Dim objReg As Object
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
computerName & "\root\default:StdRegProv")
Dim regPath As String: regPath = "Software\SyncEngines\Providers\OneDrive\"
Dim LocToWebDict As Object
Set LocToWebDict = CreateObject("Scripting.Dictionary")
Dim cid As String, libType As String, locRoot As String
Dim subKeys() As Variant, subKey As Variant
'Initializing the dict with Business OneDrive MountPoints from the registry:
objReg.EnumKey HKCU, regPath, subKeys
For Each subKey In subKeys
objReg.GetStringValue HKCU, regPath & subKey, "UrlNamespace", webRoot
objReg.GetStringValue HKCU, regPath & subKey, "MountPoint", locRoot
objReg.GetStringValue HKCU, regPath & subKey, "LibraryType", libType
If libType <> "personal" Then LocToWebDict(locRoot) = webRoot
Next subKey
'Adding personal root folder to the translation dict
objReg.GetStringValue HKCU, regPath & "Personal", "UrlNamespace", webRoot
regPath = "Software\Microsoft\OneDrive\Accounts\"
objReg.GetStringValue HKCU, regPath & "Personal", "UserFolder", locRoot
objReg.GetStringValue HKCU, regPath & "Personal", "cid", cid
If webRoot <> "" And locRoot <> "" And cid <> "" Then: _
LocToWebDict(locRoot) = webRoot & "/" & cid
Dim fileNumber As Long, lineText As String, lineParts() As String
Dim bytes() As Byte, byteStr As String: byteStr = ""
Dim pos As Long, str As String
Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
Dim parentID As String, folderID As String, folderName As String
Dim lenFolderName As Long, folderIdPattern As String
Dim odFolders As Object
Dim settPath As String
objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
settPath = settPath & "\Microsoft\OneDrive\settings\"
Dim PersGroupFoldersIniEx As Boolean
PersGroupFoldersIniEx = (Dir(settPath & "Personal\GroupFolders.ini") <> "")
Dim CidIniEx As Object: Set CidIniEx = CreateObject("Scripting.Dictionary")
Dim CidDatEx As Object: Set CidDatEx = CreateObject("Scripting.Dictionary")
For i = 0 To 9
objReg.GetStringValue HKCU, regPath & "Business" & i, "cid", cid
CidIniEx.Add Key:="Business" & i, _
item:=(Dir(settPath & "Business" & i & "\" & cid & ".ini") <> "")
CidDatEx.Add Key:="Business" & i, _
item:=(Dir(settPath & "Business" & i & "\" & cid & ".dat") <> "")
Next i
'Refining the dict using .ini and .dat files in the OneDrive settings:
Dim dirName As String: dirName = Dir(settPath, vbDirectory)
Do Until dirName = ""
objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
If cid = "" Then GoTo NextFolder
'Read dirName\cid.dat file
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".dat" For Binary Access Read _
As #fileNumber
On Error GoTo CloseFile
ReDim bytes(0 To LOF(fileNumber) - 1)
Get fileNumber, , bytes: byteStr = bytes
Close #fileNumber: fileNumber = 0: On Error GoTo 0
If dirName Like "Business#" Then
If Not (CidIniEx(dirName) And CidDatEx(dirName)) Then GoTo NextFolder
folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
ElseIf dirName = "Personal" Then
If Not PersGroupFoldersIniEx Then GoTo NextFolder
folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
End If
Set odFolders = CreateObject("Scripting.Dictionary")
pos = InStrB(1, byteStr, sig1)
Do Until pos = 0
If InStrB(pos, byteStr, sig2) - pos = 16 Then
folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
vbUnicode), vbNullChar, "")
parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
vbUnicode), vbNullChar, "")
lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
vbNullChar) - (pos + 184)) / 2) * 2
folderName = MidB(byteStr, pos + 184, lenFolderName)
If folderID Like folderIdPattern Then
odFolders.Add Key:=folderID, _
item:=Array(parentID, folderName)
End If
End If
pos = InStrB(pos + 1, byteStr, sig1)
Loop
'Read relevant .ini files
Select Case True
Case dirName Like "Business#"
'Max 9 Business OneDrive accounts can be signed in at a time.
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".ini" For _
Input Access Read As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
Select Case left$(lineText, InStr(lineText, " = ") - 1)
Case "libraryScope" '-> No change to dict necessary
Case "libraryFolder"
locRoot = Split(lineText, """")(1)
parentID = left(Split(lineText, " ")(4), 32)
For Each vKey In LocToWebDict.Keys
If vKey = locRoot Then
str = ""
Do Until Not odFolders.Exists(parentID)
str = odFolders(parentID)(1) & "/" & str
parentID = odFolders(parentID)(0)
Loop
LocToWebDict(vKey) = LocToWebDict(vKey) & str
Exit For
End If
Next vKey
Case "AddedScope"
lineParts = Split(lineText, """")
For Each vKey In LocToWebDict.Keys
webRoot = LocToWebDict(vKey)
If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
odFolders(left(Split(lineText, " ")(3), 32))(1) Then
LocToWebDict(vKey) = LocToWebDict(vKey) & _
lineParts(5)
Exit For
End If
Next vKey
Case Else
Exit Do
End Select
Loop
Close #fileNumber: fileNumber = 0: On Error GoTo 0
Case dirName = "Personal"
'Only one Personal OneDrive account can be signed in at a time.
objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
webRoot = Replace(LocToWebDict(locRoot), "/" & cid, "")
cid = ""
fileNumber = FreeFile
Open settPath & dirName & "\GroupFolders.ini" For _
Input Access Read As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
If InStr(lineText, "BaseUri = https://") And cid = "" Then
cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
folderID = left(lineText, InStr(lineText, "_") - 1)
ElseIf cid <> "" Then
LocToWebDict.Add _
Key:=locRoot & "\" & odFolders(folderID)(1), _
item:=webRoot & "/" & cid & "/" & _
Replace(lineText, folderID & "_Path = ", "")
cid = "": folderID = ""
End If
Loop
Close #fileNumber: fileNumber = 0: On Error GoTo 0
Case Else
End Select
NextFolder:
byteStr = "": Set odFolders = Nothing
dirName = Dir
Loop
Set WebToLocDict = Nothing
Set WebToLocDict = CreateObject("Scripting.Dictionary")
For Each vKey In LocToWebDict.Keys
locRoot = vKey
webRoot = LocToWebDict(vKey)
If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
WebToLocDict.Add Key:=webRoot, item:=locRoot
Next vKey
GetLocalPath = GetLocalPath(Path, False): Exit Function
CloseFile:
If fileNumber <> 0 Then: Close #fileNumber: err.Raise err
End FunctionCould you please confirm that it still works? I restructured it quite a bit, now there isn't much duplicated code remaining. I do think performance wise it could certainly be improved a bit, but I think it's good enough considering my OneDrive contains quite a lot of stuff. |
|
It still passes all my tests. |
|
Interestingly, reading the I think what takes most of the time are the various registry reads. Sub test()
Const HKCU = &H80000001
Const computerName As String = "."
Dim numReads As Long
numReads = 100
Dim objReg As Object
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
computerName & "\root\default:StdRegProv")
Dim regPath As String
regPath = "Software\Microsoft\OneDrive\Accounts\Personal\"
Dim regKey As String
regKey = "UserFolder"
Dim locRoot As String, i As Long, t As Single
t = Timer()
For i = 1 To numReads
objReg.GetStringValue HKCU, regPath, regKey, locRoot
If i = 1 Then Debug.Print locRoot
locRoot = ""
Next i
Debug.Print numReads & " registry reads with current technique: " & Timer() - t & " seconds"
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
t = Timer()
For i = 1 To numReads
locRoot = objShell.RegRead("HKCU\" & regPath & regKey)
If i = 1 Then Debug.Print locRoot
locRoot = ""
Next i
Debug.Print numReads & " registry reads with Shell technique: " & Timer() - t & " seconds"
End SubThis produces the following output for me: Is it time to change the way we read the registry or is there a different reason to go with our current technique? |
|
I looked into it a little bit and came to the following conclusions: As I'm relying on both, the EnumKey method and silent failure of the method we are using I can't replace all usage of it. But in my function, most of the reads happen to read all the business MountPoints, and for this purpose, using the Shell technique should work just fine. In fact, by implementing it that way I managed to get the total runtime of my function down by a factor of 3. I also looked into what it would take to avoid reading the registry completely, but I think that would make it unnecessarily complicated because a lot more files from the settings directory would need to be read, namely all the
This is my updated function that runs at least 3 times faster: Public Function GetLocalPath(ByVal Path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
GetLocalPath = Path: Exit Function
#End If
Const HKCU = &H80000001: Const sHKCU As String = "HKCU\"
Const computerName As String = "."
Dim webRoot As String, vKey As Variant, i As Long
Static WebToLocDict As Object
If Not WebToLocDict Is Nothing And Not rebuildCache Then
For Each vKey In WebToLocDict.Keys
If InStr(1, Path, vKey, vbBinaryCompare) = 1 Then
Path = Replace(Path, vKey, WebToLocDict(vKey), , 1)
GetLocalPath = Replace(Path, "/", "\"): Exit Function
End If
Next vKey
GetLocalPath = Path: Exit Function
End If
Dim objReg As Object
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
computerName & "\root\default:StdRegProv")
Dim oShell As Object: Set oShell = CreateObject("WScript.Shell")
Dim regPath As String: regPath = "Software\SyncEngines\Providers\OneDrive\"
Dim LocToWebDict As Object
Set LocToWebDict = CreateObject("Scripting.Dictionary")
Dim cid As String, libType As String, locRoot As String
Dim subKeys() As Variant, subKey As Variant
'Initializing the dict with Business OneDrive MountPoints from the registry:
objReg.EnumKey HKCU, regPath, subKeys
For Each subKey In subKeys
libType = oShell.RegRead(sHKCU & regPath & subKey & "\LibraryType")
If libType <> "personal" Then
webRoot = oShell.RegRead(sHKCU & regPath & subKey & "\UrlNamespace")
locRoot = oShell.RegRead(sHKCU & regPath & subKey & "\MountPoint")
LocToWebDict(locRoot) = webRoot
End If
Next subKey
'Adding personal root folder to the translation dict
objReg.GetStringValue HKCU, regPath & "Personal", "UrlNamespace", webRoot
regPath = "Software\Microsoft\OneDrive\Accounts\"
objReg.GetStringValue HKCU, regPath & "Personal", "UserFolder", locRoot
objReg.GetStringValue HKCU, regPath & "Personal", "cid", cid
If webRoot <> "" And locRoot <> "" And cid <> "" Then: _
LocToWebDict(locRoot) = webRoot & "/" & cid
Dim fileNumber As Long, lineText As String, lineParts() As String
Dim bytes() As Byte, byteStr As String: byteStr = ""
Dim pos As Long, str As String
Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
Dim parentID As String, folderID As String, folderName As String
Dim lenFolderName As Long, folderIdPattern As String, odFolders As Object
Dim settPath As String
objReg.GetStringValue HKCU, "Volatile Environment", "LOCALAPPDATA", settPath
settPath = settPath & "\Microsoft\OneDrive\settings\"
Dim PersGroupFoldersIniEx As Boolean
PersGroupFoldersIniEx = (Dir(settPath & "Personal\GroupFolders.ini") <> "")
Dim CidIniEx As Object: Set CidIniEx = CreateObject("Scripting.Dictionary")
Dim CidDatEx As Object: Set CidDatEx = CreateObject("Scripting.Dictionary")
For i = 0 To 9
objReg.GetStringValue HKCU, regPath & "Business" & i, "cid", cid
CidIniEx.Add Key:="Business" & i, _
item:=(Dir(settPath & "Business" & i & "\" & cid & ".ini") <> "")
CidDatEx.Add Key:="Business" & i, _
item:=(Dir(settPath & "Business" & i & "\" & cid & ".dat") <> "")
Next i
'Refining the dict using .ini and .dat files in the OneDrive settings:
Dim dirName As String: dirName = Dir(settPath, vbDirectory)
Do Until dirName = ""
objReg.GetStringValue HKCU, regPath & dirName, "cid", cid
If cid = "" Then GoTo NextFolder
'Read dirName\cid.dat file
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".dat" For Binary Access Read _
As #fileNumber
On Error GoTo CloseFile
ReDim bytes(0 To LOF(fileNumber) - 1)
Get fileNumber, , bytes: byteStr = bytes
Close #fileNumber: fileNumber = 0: On Error GoTo 0
If dirName Like "Business#" Then
If Not (CidIniEx(dirName) And CidDatEx(dirName)) Then GoTo NextFolder
folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
ElseIf dirName = "Personal" Then
If Not PersGroupFoldersIniEx Then GoTo NextFolder
folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
End If
Set odFolders = CreateObject("Scripting.Dictionary")
pos = InStrB(1, byteStr, sig1)
Do Until pos = 0
If InStrB(pos, byteStr, sig2) - pos = 16 Then
folderID = Replace(StrConv(MidB(byteStr, pos + 24, 32), _
vbUnicode), vbNullChar, "")
parentID = Replace(StrConv(MidB(byteStr, pos + 63, 32), _
vbUnicode), vbNullChar, "")
lenFolderName = -Int(-(InStrB(pos + 184, byteStr, _
vbNullChar) - (pos + 184)) / 2) * 2
folderName = MidB(byteStr, pos + 184, lenFolderName)
If folderID Like folderIdPattern Then
odFolders.Add Key:=folderID, _
item:=Array(parentID, folderName)
End If
End If
pos = InStrB(pos + 1, byteStr, sig1)
Loop
'Read relevant .ini files
Select Case True
Case dirName Like "Business#"
'Max 9 Business OneDrive accounts can be signed in at a time.
fileNumber = FreeFile
Open settPath & dirName & "\" & cid & ".ini" For Input Access Read _
As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
Select Case left$(lineText, InStr(lineText, " = ") - 1)
Case "libraryScope" '-> No change to dict necessary
Case "libraryFolder"
locRoot = Split(lineText, """")(1)
parentID = left(Split(lineText, " ")(4), 32)
For Each vKey In LocToWebDict.Keys
If vKey = locRoot Then
str = ""
Do Until Not odFolders.Exists(parentID)
str = odFolders(parentID)(1) & "/" & str
parentID = odFolders(parentID)(0)
Loop
LocToWebDict(vKey) = LocToWebDict(vKey) & str
Exit For
End If
Next vKey
Case "AddedScope"
lineParts = Split(lineText, """")
For Each vKey In LocToWebDict.Keys
webRoot = LocToWebDict(vKey)
If InStr(1, webRoot, lineParts(1), vbBinaryCompare) = _
1 And Mid(vKey, InStrRev(vKey, "\") + 1) = _
odFolders(left(Split(lineText, " ")(3), 32))(1) Then
LocToWebDict(vKey) = LocToWebDict(vKey) & _
lineParts(5)
Exit For
End If
Next vKey
Case Else
Exit Do
End Select
Loop
Close #fileNumber: fileNumber = 0: On Error GoTo 0
Case dirName = "Personal"
'Only one Personal OneDrive account can be signed in at a time.
objReg.GetStringValue HKCU, regPath & dirName, "UserFolder", locRoot
webRoot = Replace(LocToWebDict(locRoot), "/" & cid, "")
cid = ""
fileNumber = FreeFile
Open settPath & dirName & "\GroupFolders.ini" For _
Input Access Read As #fileNumber
On Error GoTo CloseFile
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
If InStr(lineText, "BaseUri = https://") And cid = "" Then
cid = LCase(Mid(lineText, InStrRev(lineText, "/") + 1, 16))
folderID = left(lineText, InStr(lineText, "_") - 1)
ElseIf cid <> "" Then
LocToWebDict.Add _
Key:=locRoot & "\" & odFolders(folderID)(1), _
item:=webRoot & "/" & cid & "/" & _
Replace(lineText, folderID & "_Path = ", "")
cid = "": folderID = ""
End If
Loop
Close #fileNumber: fileNumber = 0: On Error GoTo 0
Case Else
End Select
NextFolder:
byteStr = "": Set odFolders = Nothing
dirName = Dir
Loop
Set WebToLocDict = Nothing
Set WebToLocDict = CreateObject("Scripting.Dictionary")
For Each vKey In LocToWebDict.Keys
locRoot = vKey: webRoot = LocToWebDict(vKey)
If right(locRoot, 1) = "\" Then locRoot = left(locRoot, Len(locRoot) - 1)
If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
WebToLocDict.Add Key:=webRoot, item:=locRoot
Next vKey
GetLocalPath = GetLocalPath(Path, False): Exit Function
CloseFile:
If fileNumber <> 0 Then: Close #fileNumber: err.Raise err
End Function |
|
Hi @guwidoe , Funny that you mentioned skipping registry entirely. I was working on exactly that this morning. I've seen in many comments on Stack Overflow that some people cannot read registry at all (due to company policy). So, skipping registry should help those people. Reading the ClientPolicy files is super fast so overall the solution is actually faster. Can you please test the below? Thanks! Option Explicit
Private Type OneDriveMap
localPath As String
webPath As String
End Type
'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
'
Dim arrMap() As OneDriveMap: PopulateMaps arrMap, rebuildCache:=False
Dim i As Long
Dim webPath
Dim tempPath As String
Dim rPart As String
'
For i = LBound(arrMap) To UBound(arrMap)
webPath = arrMap(i).webPath
tempPath = Left$(odWebPath, Len(webPath))
If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
Next i
If i > UBound(arrMap) Then Exit Function
'
rPart = Replace(odWebPath, webPath, vbNullString, , , vbTextCompare)
GetOneDriveLocalPath = BuildPath(arrMap(i).localPath, rPart)
End Function
Private Sub PopulateMaps(ByRef arrMap() As OneDriveMap _
, ByVal rebuildCache As Boolean)
Static arrLocalMap() As OneDriveMap
Static isSet As Boolean
'
If rebuildCache Then isSet = False
If isSet Then
arrMap = arrLocalMap
Exit Sub
End If
'
Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
Dim settingsPath As String
Dim folderPath As Variant
Dim folderName As String
Dim collLocalPaths As New Collection
Dim collWebPaths As New Collection
'
settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
For Each folderPath In GetFolders(settingsPath)
folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
If folderName Like "Business*" Then
AddBusinessPaths folderPath, collLocalPaths, collWebPaths
ElseIf folderName = "Personal" Then
AddPersonalPaths folderPath, collLocalPaths, collWebPaths
End If
Next folderPath
If collLocalPaths.Count = 0 Then
ReDim arrLocalMap(0 To 0)
Else
ReDim arrLocalMap(0 To collLocalPaths.Count - 1)
Dim i As Long
Dim v As Variant
'
i = 0
For Each v In collLocalPaths
arrLocalMap(i).localPath = v
i = i + 1
Next v
i = 0
For Each v In collWebPaths
arrLocalMap(i).webPath = v
i = i + 1
Next v
End If
arrMap = arrLocalMap
isSet = True
End Sub
Private Sub AddBusinessPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Const businessIniMask As String = "????????-????-????-????-????????????.ini"
Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
If LenB(iniName) = 0 Then Exit Sub
'
Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
Dim parts() As String
Dim tempMount As String
Dim tempURL As String
Dim tempID As String
Dim tempFolder As String
Dim prevID As String
Dim collFolders As Collection
Dim collParents As Collection
Dim collPending As New Collection
'
For Each lineText In Split(bytes, vbNewLine)
Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
Case "libraryScope"
parts = Split(lineText, """")
tempMount = parts(9)
If LenB(tempMount) = 0 Then tempID = Split(parts(0), " ")(2)
If parts(3) = "ODB" Then
tempURL = GetUrlNamespace(folderPath)
Else
parts = Split(parts(8), " ")
tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1))
End If
If LenB(tempMount) = 0 Then
collPending.Add tempURL, tempID
Else
collLocalPaths.Add tempMount
collWebPaths.Add tempURL
End If
Case "libraryFolder"
If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath, collParents)
parts = Split(lineText, """")
tempMount = parts(1)
parts = Split(parts(0), " ")
tempURL = collPending(parts(3))
tempID = Split(parts(4), "+")(0)
tempFolder = vbNullString
On Error Resume Next
Do
tempFolder = collFolders(tempID) & "/" & tempFolder
prevID = tempID
tempID = collParents(tempID)
Loop Until Err.Number <> 0 Or prevID = tempID
On Error GoTo 0
If LenB(tempFolder) > 0 Then
collLocalPaths.Add tempMount
collWebPaths.Add tempURL & tempFolder
End If
Case "AddedScope"
If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath)
parts = Split(lineText, """")
collLocalPaths.Add collLocalPaths(1) & "\" & collFolders(Split(parts(0), " ")(3))
tempURL = parts(5)
parts = Split(parts(4), " ")
tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1) & parts(4)) & tempURL
collWebPaths.Add tempURL
Case Else
Exit For
End Select
Next lineText
End Sub
Private Function GetUrlNamespace(ByVal folderPath As String _
, Optional ByVal clientSignature As String) As String
Const nTag As String = "DavUrlNamespace"
Dim bytes() As Byte
Dim lineText As Variant
'
ReadBytes BuildPath(folderPath, "ClientPolicy" & clientSignature & ".ini"), bytes
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, Len(nTag)) = nTag Then
GetUrlNamespace = Mid$(lineText, InStr(Len(nTag) + 2, lineText, "https://"))
Exit Function
End If
Next lineText
End Function
Private Sub AddPersonalPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
Dim iniPath As String
'
Do
iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
If IsFile(iniPath) Then Exit Do
datName = Dir
Loop Until LenB(datName) = 0
'
Dim tempMount As String
Dim tempURL As String: tempURL = GetUrlNamespace(folderPath) & "/"
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
'
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, InStr(1, lineText, " ") - 1) = "library" Then
tempMount = Split(lineText, """")(3) & "\"
Exit For
End If
Next lineText
collLocalPaths.Add tempMount
collWebPaths.Add tempURL & Replace(datName, ".dat", vbNullString) & "/"
'
Dim groupPath As String: groupPath = BuildPath(folderPath, "GroupFolders.ini")
Dim cid As String
Dim i As Long
Dim relPath As String
Dim folderID As String
Dim collFolders As Collection
'
If Not IsFile(groupPath) Then Exit Sub
ReadBytes groupPath, bytes
'
For Each lineText In Split(bytes, vbNewLine)
If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
i = InStr(1, cid, "!")
If i > 0 Then cid = Left$(cid, i - 1)
Else
i = InStr(1, lineText, "_Path", vbTextCompare)
If i > 0 Then
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
folderID = Left$(lineText, i - 1)
If collFolders Is Nothing Then
Set collFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
End If
If collFolders.Count > 0 Then
collLocalPaths.Add tempMount & collFolders(folderID)
collWebPaths.Add tempURL & cid & "/" & relPath
End If
End If
End If
Next lineText
End Sub
'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
, Optional ByRef outParents As Collection) As Collection
Dim b() As Byte: ReadBytes filePath, b
Dim s As String: s = b
Dim size As Long: size = LenB(s)
If size = 0 Then Exit Function
'
Dim hFolder As String
Dim hCheck As String
Dim i As Long
Dim v As Variant
Dim stepSize As Long
Dim bytes As Long
Dim folderID As String
Dim parentID As String
Dim folderName As String
Dim collFolders As New Collection
Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
'
hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
If outParents Is Nothing Then Set outParents = New Collection
'
For Each v In Array(16, 8)
stepSize = v
i = InStrB(stepSize, s, hCheck)
Do While i > stepSize And i < size - 168
If MidB$(s, i - stepSize, 1) = hFolder Then
i = i + 8
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 39
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 121
bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
If bytes < 0 Then bytes = 0
folderName = MidB$(s, i, bytes)
'
If LenB(folderID) > 0 And LenB(parentID) > 0 Then
collFolders.Add folderName, folderID
outParents.Add parentID, folderID
End If
End If
i = InStrB(i + 1, s, hCheck)
Loop
If collFolders.Count > 0 Then Exit For
Next v
Set GetODFolders = collFolders
End Function
'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
Dim fileNumber As Long: fileNumber = FreeFile()
Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
'
Open filePath For Binary Access Read As #fileNumber
ReDim result(0 To LOF(fileNumber) - 1)
Get fileNumber, , result
Close #fileNumber
'
If mustDelete Then DeleteFile filePath
End Sub |
I have seen one such comment too but decided it was more important to keep my solution as short as possible since I am trying to shove everything into a single procedure. Now that you are going for it maybe I'll write such a solution too. Runtime wise your new solution is now very similar to my last solution, maybe a smidge faster. However, there are still two tests that fail, which my solution passes: Both of these cases are related to adding a SharePoint library as a link to your personal business OneDrive, and for some reason, your solution substitutes the Business1 local path instead of the Business2 one. I think this should be easy to fix. I have one more question regarding your implementation of For Each v In Array(16, 8)
stepSize = v
i = InStrB(stepSize, s, Check)
Do While i > stepSize And i < size - 168
'....
Loop
Next vWhat is |
|
Hi @guwidoe , Thanks! Yeah, forgot a small detail. Fixed now and it should pass all tests: Option Explicit
Private Type OneDriveMap
localPath As String
webPath As String
End Type
'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
'
Dim arrMap() As OneDriveMap: PopulateMaps arrMap, rebuildCache:=False
Dim i As Long
Dim webPath
Dim tempPath As String
Dim rPart As String
'
For i = LBound(arrMap) To UBound(arrMap)
webPath = arrMap(i).webPath
tempPath = Left$(odWebPath, Len(webPath))
If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
Next i
If i > UBound(arrMap) Then Exit Function
'
rPart = Replace(odWebPath, webPath, vbNullString, , , vbTextCompare)
GetOneDriveLocalPath = BuildPath(arrMap(i).localPath, rPart)
End Function
Private Sub PopulateMaps(ByRef arrMap() As OneDriveMap _
, ByVal rebuildCache As Boolean)
Static arrLocalMap() As OneDriveMap
Static isSet As Boolean
'
If rebuildCache Then isSet = False
If isSet Then
arrMap = arrLocalMap
Exit Sub
End If
'
Const settingsRelPath As String = "Microsoft\OneDrive\settings\"
Dim settingsPath As String
Dim folderPath As Variant
Dim folderName As String
Dim collLocalPaths As New Collection
Dim collWebPaths As New Collection
'
settingsPath = BuildPath(Environ$("LOCALAPPDATA"), settingsRelPath)
For Each folderPath In GetFolders(settingsPath)
folderName = Right$(folderPath, Len(folderPath) - Len(settingsPath))
If folderName Like "Business*" Then
AddBusinessPaths folderPath, collLocalPaths, collWebPaths
ElseIf folderName = "Personal" Then
AddPersonalPaths folderPath, collLocalPaths, collWebPaths
End If
Next folderPath
If collLocalPaths.Count = 0 Then
ReDim arrLocalMap(0 To 0)
Else
ReDim arrLocalMap(0 To collLocalPaths.Count - 1)
Dim i As Long
Dim v As Variant
'
i = 0
For Each v In collLocalPaths
arrLocalMap(i).localPath = v
i = i + 1
Next v
i = 0
For Each v In collWebPaths
arrLocalMap(i).webPath = v
i = i + 1
Next v
End If
arrMap = arrLocalMap
isSet = True
End Sub
Private Sub AddBusinessPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Const businessIniMask As String = "????????-????-????-????-????????????.ini"
Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
If LenB(iniName) = 0 Then Exit Sub
'
Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
Dim mainIndex As Long
Dim parts() As String
Dim tempMount As String
Dim tempURL As String
Dim tempID As String
Dim tempFolder As String
Dim prevID As String
Dim collFolders As Collection
Dim collParents As Collection
Dim collPending As New Collection
'
For Each lineText In Split(bytes, vbNewLine)
Select Case Left$(lineText, InStr(1, lineText, " ") - 1)
Case "libraryScope"
parts = Split(lineText, """")
tempMount = parts(9)
If LenB(tempMount) = 0 Then tempID = Split(parts(0), " ")(2)
If parts(3) = "ODB" Then
tempURL = GetUrlNamespace(folderPath)
mainIndex = collLocalPaths.Count + 1
Else
parts = Split(parts(8), " ")
tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1))
End If
If LenB(tempMount) = 0 Then
collPending.Add tempURL, tempID
Else
collLocalPaths.Add tempMount
collWebPaths.Add tempURL
End If
Case "libraryFolder"
If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath, collParents)
parts = Split(lineText, """")
tempMount = parts(1)
parts = Split(parts(0), " ")
tempURL = collPending(parts(3))
tempID = Split(parts(4), "+")(0)
tempFolder = vbNullString
On Error Resume Next
Do
tempFolder = collFolders(tempID) & "/" & tempFolder
prevID = tempID
tempID = collParents(tempID)
Loop Until Err.Number <> 0 Or prevID = tempID
On Error GoTo 0
If LenB(tempFolder) > 0 Then
collLocalPaths.Add tempMount
collWebPaths.Add tempURL & tempFolder
End If
Case "AddedScope"
If collFolders Is Nothing Then Set collFolders = GetODFolders(datPath)
parts = Split(lineText, """")
collLocalPaths.Add collLocalPaths(mainIndex) & "\" & collFolders(Split(parts(0), " ")(3))
tempURL = parts(5)
parts = Split(parts(4), " ")
tempURL = GetUrlNamespace(folderPath, "_" & parts(3) & parts(1) & parts(4)) & tempURL
collWebPaths.Add tempURL
Case Else
Exit For
End Select
Next lineText
End Sub
Private Function GetUrlNamespace(ByVal folderPath As String _
, Optional ByVal clientSignature As String) As String
Const nTag As String = "DavUrlNamespace"
Dim bytes() As Byte
Dim lineText As Variant
'
ReadBytes BuildPath(folderPath, "ClientPolicy" & clientSignature & ".ini"), bytes
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, Len(nTag)) = nTag Then
GetUrlNamespace = Mid$(lineText, InStr(Len(nTag) + 2, lineText, "https://"))
Exit Function
End If
Next lineText
End Function
Private Sub AddPersonalPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
Dim iniPath As String
'
Do
iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
If IsFile(iniPath) Then Exit Do
datName = Dir
Loop Until LenB(datName) = 0
'
Dim tempMount As String
Dim tempURL As String: tempURL = GetUrlNamespace(folderPath) & "/"
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
'
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, InStr(1, lineText, " ") - 1) = "library" Then
tempMount = Split(lineText, """")(3) & "\"
Exit For
End If
Next lineText
collLocalPaths.Add tempMount
collWebPaths.Add tempURL & Replace(datName, ".dat", vbNullString) & "/"
'
Dim groupPath As String: groupPath = BuildPath(folderPath, "GroupFolders.ini")
Dim cid As String
Dim i As Long
Dim relPath As String
Dim folderID As String
Dim collFolders As Collection
'
If Not IsFile(groupPath) Then Exit Sub
ReadBytes groupPath, bytes
'
For Each lineText In Split(bytes, vbNewLine)
If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
i = InStr(1, cid, "!")
If i > 0 Then cid = Left$(cid, i - 1)
Else
i = InStr(1, lineText, "_Path", vbTextCompare)
If i > 0 Then
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
folderID = Left$(lineText, i - 1)
If collFolders Is Nothing Then
Set collFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
End If
If collFolders.Count > 0 Then
collLocalPaths.Add tempMount & collFolders(folderID)
collWebPaths.Add tempURL & cid & "/" & relPath
End If
End If
End If
Next lineText
End Sub
'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
, Optional ByRef outParents As Collection) As Collection
Dim b() As Byte: ReadBytes filePath, b
Dim s As String: s = b
Dim size As Long: size = LenB(s)
If size = 0 Then Exit Function
'
Dim hFolder As String
Dim hCheck As String
Dim i As Long
Dim v As Variant
Dim stepSize As Long
Dim bytes As Long
Dim folderID As String
Dim parentID As String
Dim folderName As String
Dim collFolders As New Collection
Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
'
hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x0100000000000000
If outParents Is Nothing Then Set outParents = New Collection
'
For Each v In Array(16, 8)
stepSize = v
i = InStrB(stepSize, s, hCheck)
Do While i > stepSize And i < size - 168
If MidB$(s, i - stepSize, 1) = hFolder Then
i = i + 8
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 39
bytes = InStrB(i, s, vbNullByte) - i
If bytes < 0 Then bytes = 0
If bytes > 39 Then bytes = 39
parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
'
i = i + 121
bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
If bytes < 0 Then bytes = 0
folderName = MidB$(s, i, bytes)
'
If LenB(folderID) > 0 And LenB(parentID) > 0 Then
collFolders.Add folderName, folderID
outParents.Add parentID, folderID
End If
End If
i = InStrB(i + 1, s, hCheck)
Loop
If collFolders.Count > 0 Then Exit For
Next v
Set GetODFolders = collFolders
End Function
'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
Dim fileNumber As Long: fileNumber = FreeFile()
Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
'
Open filePath For Binary Access Read As #fileNumber
ReDim result(0 To LOF(fileNumber) - 1)
Get fileNumber, , result
Close #fileNumber
'
If mustDelete Then DeleteFile filePath
End Sub
Depending on the OneDrive version you can have the offsets in 8 bytes rather than 16 (for the dat file). So, I try 16 first and if it fails then I try 8. It seems we are getting closer to our goals. 😊 I am still planning to rewrite and make the code smaller but just wanted to be sure it works first. |
Success! This version passes all my tests!
Yes! I'm very glad, what a journey this was! I had a great time working on this with you! This was a good example of how important proper testing is in software development. If you want, I'd be very glad if you could let me know if you come across different interesting vba challenges in the future, I'm always looking for ways to improve my knowledge and I think this is a very good way to learn. I have looked at some of your posts on CodeReview and I'm very impressed by your code, I think it's some of the best vba code out there. What are the resources you use to improve? |
Likewise, was a pleasure for me too! You were very thorough in your testing while I was being lazy.
I am convinced. However, if we post a smaller footprint response on all of the relevant forum questions then we might get feedback when stuff breaks from other users. In other words, get indirect help with testing and coverage.
I was actually thinking to ask you if you'd like to collaborate on other VBA projects. I'm glad you're thinking the same. VBA is lacking a lot of functionality and there are plenty of gaps that we could fill in order to help others as well. I will think of some interesting mini projects and I will contact you. Or maybe you have something in mind and I will be glad to join in. We can then decide how we want to approach it and where (e.g. a repo on your account, a repo on my account or a joint 'organization' - for me it does not matter too much as my only goal is to help other people).
I know of only one 'good' way to learn and that is to solve problems i.e. learn by doing. I'm with you on this one.
Thank you very much! You are very kind.
I focus on specific problems and I am stubborn enough not to give up. I follow up in the smallest details and read relevant articles and books that help me get closer to solving the problem. Resources are always dependent on the problem at hand and so they are much easier to find. For example I spent 4 weeks on trying to find a faster alternative to CopyMemory and tried so many different things that eventually I came with something completely new as found here but that was only made possible by being stubborn. Learned quite a lot in the process.
My email address should be public but here it is anyway: cristian.buse@yahoo.com I will be rewriting the above code so that I get a smaller footprint. Will post it here when I'm done. Best Regards, |
|
Hi @guwidoe , I've refactored my code. I don't think I can make it smaller without damaging readability. Can you please test it one last time? Option Explicit
'*******************************************************************************
'Returns the local path for a OneDrive web path
'Returns null string if the path provided is not a valid OneDrive web path
'*******************************************************************************
Public Function GetOneDriveLocalPath(ByVal odWebPath As String) As String
If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function
'
Dim collLocalPaths As Collection
Dim collWebPaths As Collection
Dim webPath As Variant
Dim tempPath As String
Dim rPart As String
'
PopulatePaths collLocalPaths, collWebPaths, rebuildCache:=False
For Each webPath In collWebPaths
tempPath = Left$(odWebPath, Len(webPath))
If StrComp(tempPath, webPath, vbTextCompare) = 0 Then Exit For
Next webPath
If IsEmpty(webPath) Then Exit Function
'
rPart = Replace(odWebPath, webPath, vbNullString, Compare:=vbTextCompare)
GetOneDriveLocalPath = BuildPath(collLocalPaths(webPath), rPart)
End Function
Private Sub PopulatePaths(ByRef collLocal As Collection _
, ByRef collWeb As Collection _
, ByVal rebuildCache As Boolean)
Static collLocalPaths As Collection
Static collWebPaths As Collection
Dim folderPath As Variant
Dim folderName As String
Dim appPath As String
Dim redo As Boolean: redo = rebuildCache Or collLocalPaths Is Nothing
'
If redo Then
Set collLocalPaths = New Collection
Set collWebPaths = New Collection
End If
Set collLocal = collLocalPaths
Set collWeb = collWebPaths
If Not redo Then Exit Sub
'
appPath = BuildPath(Environ$("LOCALAPPDATA"), "Microsoft\OneDrive\settings\")
For Each folderPath In GetFolders(appPath)
folderName = Right$(folderPath, Len(folderPath) - Len(appPath))
If folderName Like "Business*" Then
AddBusinessPaths folderPath, collLocalPaths, collWebPaths
ElseIf folderName = "Personal" Then
AddPersonalPaths folderPath, collLocalPaths, collWebPaths
End If
Next folderPath
End Sub
Private Sub AddBusinessPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Const businessIniMask As String = "????????-????-????-????-????????????.ini"
Dim iniName As String: iniName = Dir(BuildPath(folderPath, businessIniMask))
If LenB(iniName) = 0 Then Exit Sub
'
Dim iniPath As String: iniPath = BuildPath(folderPath, iniName)
Dim datPath As String: datPath = Replace(iniPath, ".ini", ".dat")
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
Dim temp() As String
Dim tempMount As String
Dim mainMount As String
Dim tempURL As String
Dim cFolders As Collection
Dim cParents As Collection
Dim cPending As New Collection
Dim canAdd As Boolean
'
For Each lineText In Split(bytes, vbNewLine)
Dim parts() As String: parts = Split(lineText, """")
Select Case Left$(lineText, InStr(1, lineText, " "))
Case "libraryScope "
tempMount = parts(9)
canAdd = (LenB(tempMount) > 0)
If parts(3) = "ODB" Then
mainMount = tempMount
tempURL = GetUrlNamespace(folderPath)
Else
temp = Split(parts(8), " ")
tempURL = GetUrlNamespace(folderPath, "_" & temp(3) & temp(1))
End If
If Not canAdd Then cPending.Add tempURL, Split(parts(0), " ")(2)
Case "libraryFolder "
If cFolders Is Nothing Then
Set cFolders = GetODFolders(datPath, cParents)
End If
tempMount = parts(1)
temp = Split(parts(0), " ")
tempURL = cPending(temp(3))
Dim tempID As String: tempID = Split(temp(4), "+")(0)
Dim tempFolder As String: tempFolder = vbNullString
On Error Resume Next
Do
tempFolder = cFolders(tempID) & "/" & tempFolder
tempID = cParents(tempID)
Loop Until Err.Number <> 0
On Error GoTo 0
canAdd = (LenB(tempFolder) > 0)
tempURL = tempURL & tempFolder
Case "AddedScope "
If cFolders Is Nothing Then Set cFolders = GetODFolders(datPath)
tempMount = mainMount & "\" & cFolders(Split(parts(0), " ")(3))
tempURL = parts(5)
temp = Split(parts(4), " ")
tempURL = GetUrlNamespace(folderPath, "_" & temp(3) & temp(1) _
& temp(4)) & tempURL
canAdd = True
Case Else
Exit For
End Select
If canAdd Then
collLocalPaths.Add tempMount, tempURL
collWebPaths.Add tempURL, tempMount
End If
Next lineText
End Sub
Private Function GetUrlNamespace(ByVal folderPath As String _
, Optional ByVal cSignature As String) As String
Const nTag As String = "DavUrlNamespace"
Dim bytes() As Byte
Dim lineText As Variant
'
ReadBytes BuildPath(folderPath, "ClientPolicy" & cSignature & ".ini"), bytes
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, Len(nTag)) = nTag Then
GetUrlNamespace = Mid$(lineText, InStr(Len(nTag), lineText, "https"))
Exit Function
End If
Next lineText
End Function
Private Sub AddPersonalPaths(ByVal folderPath As String _
, ByVal collLocalPaths As Collection _
, ByVal collWebPaths As Collection)
Dim datName As String: datName = Dir(BuildPath(folderPath, "*.dat"))
Dim iniPath As String
Do
iniPath = BuildPath(folderPath, Replace(datName, ".dat", ".ini"))
If IsFile(iniPath) Then Exit Do
datName = Dir
If LenB(datName) = 0 Then Exit Sub
Loop
Dim mainURL As String: mainURL = GetUrlNamespace(folderPath) & "/"
Dim cid As String: cid = Replace(datName, ".dat", vbNullString)
Dim tempURL As String: tempURL = mainURL & cid & "/"
Dim bytes() As Byte: ReadBytes iniPath, bytes
Dim lineText As Variant
Dim mainMount As String
'
For Each lineText In Split(bytes, vbNewLine)
If Left$(lineText, InStr(1, lineText, " ")) = "library " Then
mainMount = Split(lineText, """")(3) & "\"
Exit For
End If
Next lineText
collLocalPaths.Add mainMount, tempURL
collWebPaths.Add tempURL, mainMount
'
Dim groupPath As String
Dim i As Long
Dim relPath As String
Dim folderID As String
Dim cFolders As Collection
Dim tempMount As String
'
groupPath = BuildPath(folderPath, "GroupFolders.ini")
If Not IsFile(groupPath) Then Exit Sub
ReadBytes groupPath, bytes
'
For Each lineText In Split(bytes, vbNewLine)
If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then
cid = Mid$(lineText, InStrRev(lineText, "/") + 1)
i = InStr(1, cid, "!")
If i > 0 Then cid = Left$(cid, i - 1)
Else
i = InStr(1, lineText, "_Path", vbTextCompare)
If i > 0 Then
relPath = Mid$(lineText, InStr(lineText, " = ") + 3)
folderID = Left$(lineText, i - 1)
If cFolders Is Nothing Then
Set cFolders = GetODFolders(Replace(iniPath, ".ini", ".dat"))
End If
If cFolders.Count > 0 Then
tempMount = mainMount & cFolders(folderID)
tempURL = mainURL & cid & "/" & relPath
collLocalPaths.Add tempMount, tempURL
collWebPaths.Add tempURL, tempMount
End If
End If
End If
Next lineText
End Sub
'*******************************************************************************
'Utility - Retrieves all folders from an OneDrive user .dat file
'*******************************************************************************
Private Function GetODFolders(ByVal filePath As String _
, Optional ByRef outParents As Collection) As Collection
Dim b() As Byte: ReadBytes filePath, b
Dim s As String: s = b
Dim size As Long: size = LenB(s): If size = 0 Then Exit Function
Dim i As Long
Dim v As Variant
Dim cFolders As New Collection
Dim stepSize As Long
Dim bytes As Long
Dim folderID As String
Dim parentID As String
Dim folderName As String
Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
Dim hFolder As String: hFolder = StrConv(Chr$(&H2), vbFromUnicode) 'x02
Dim hCheck As String: hCheck = ChrW$(&H1) & String(3, vbNullChar) 'x01..
'
If outParents Is Nothing Then Set outParents = New Collection
For Each v In Array(16, 8)
stepSize = v
i = InStrB(stepSize, s, hCheck)
Do While i > stepSize And i < size - 168
If MidB$(s, i - stepSize, 1) = hFolder Then
i = i + 8
bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, 39)
folderID = StrConv(MidB$(s, i, bytes), vbUnicode)
i = i + 39
bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, 39)
parentID = StrConv(MidB$(s, i, bytes), vbUnicode)
i = i + 121
bytes = -Int(-(InStrB(i, s, vbNullChar) - i) / 2) * 2
If bytes < 0 Then bytes = 0
folderName = MidB$(s, i, bytes)
If LenB(folderID) > 0 And LenB(parentID) > 0 Then
cFolders.Add folderName, folderID
outParents.Add parentID, folderID
End If
End If
i = InStrB(i + 1, s, hCheck)
Loop
If cFolders.Count > 0 Then Exit For
Next v
Set GetODFolders = cFolders
End Function
Private Function Clamp(ByVal v As Long, ByVal lowB As Long, uppB As Long) As Long
If v < lowB Then
Clamp = lowB
ElseIf v > uppB Then
Clamp = uppB
Else
Clamp = v
End If
End Function
'*******************************************************************************
'Utility - Reads a file into an array of Bytes
'*******************************************************************************
Private Sub ReadBytes(ByVal filePath As String, ByRef result() As Byte)
Dim fileNumber As Long: fileNumber = FreeFile()
Dim mustDelete As Boolean: mustDelete = Not IsFile(filePath)
'
Open filePath For Binary Access Read As #fileNumber
ReDim result(0 To LOF(fileNumber) - 1)
Get fileNumber, , result
Close #fileNumber
'
If mustDelete Then DeleteFile filePath
End Sub |
|
Hi @cristianbuse, I just tested your final solution and it still passes all my tests, I'm looking forward to seeing your updated library. I consider the issue resolved and I will send you my final solution once I have time to complete it. Thanks for everything! I have sent you a mail with my contact details and I'm looking forward to hearing from you! |
|
Thanks @guwidoe , Just realized that there is one more issue to solve. For example, if both the following URLs are syncronized as different mounts:
Just something to keep in mind when you finalize your solution. I will push with this fixed. |
|
I have thought about this already and I came to the conclusion that this is not a problem. The reason is, that it is impossible to synchronize a child folder if you have already synchronized one of its parent folders. In your example, the mount I recommend you try this out for yourself just in case I'm missing something, but I'm pretty sure I'm not. |
|
You are correct, I just did that a few minutes ago. But I had to fix the viceversa logic as that is where the problem was. |
Registry is not used anymore. Detection now works for syncronized SharePoint folders and shared Business/Personal OneDrive folders. Many thanks to @guwidoe!
|
Many thanks @guwidoe ! Will keep in touch. |
Hello, I love the work you did with your VBA Libraries!
I recently ran into an issue with my GetLocalPath function, then I remembered yours, gave it a try, and ran into even more issues.
The first problem, which only occurred in your function, is that the registry keys you read don't seem to contain information for all of the possible WebPaths.
I have these two "Accounts" in my registry, yet only the Business1 one contains a bunch of subkeys, while the Personal one only contains (Standard), so it's completely empty. This is not too big of a surprise, because I'm only logged in on my business account on that machine.
This is a problem, because even if you only have one Business account logged in, there can be at least two (I know of...) different WebPath "roots", one for the "Personal" (Business) OneDrive folder, and one for the "SharePoint" folder.
"Personal" (Business) OneDrive
"SharePoint" folder
Because you only read one of the possible WebPaths (
ServiceEndpointUri), this leaves you with too little information to deal with all possible WebPaths.There is information about the paths in the Registry folder you are checking, but I'm not sure it's enough. I have the keys
SPOResourceId->https://%company_name%online-my.sharepoint.com/(Personal)TeamSiteSPOResourceId->https://%company_name%online.sharepoint.com/(SharePoint)which contain something like the "roots root" of the two possible WebPaths. But I'm not even sure if reading these would give enough information since the actual SharePoint WebPath has a longer root, something like
https://%company_name%online.sharepoint.com/sites/workspaces/and I don't know if the/sites/workspaces/is the same in every possible SharePoint WebPath.This doesn't really matter since I would recommend reading different RegistryKeys anyways, which you know about too I suppose. These are of course located at
\HKEY_CURRENT_USER\Software\SyncEngines\Providers\OneDriveHere, reading the
UrlNamespaceandMountPointsubkeys of all the subfolders gives almost all the necessary information to construct the right local paths, but there is still a little annoyance, which is where I ran into the problem in the first place.That is if the synchronized folder is not at the base of the folder structure on the server, the WebPath will still contain all the server subfolders which do not exist in the local mount, but the
UrlNamespacekey will still only contain the "root" of the WebPath.Hence, if we construct a LocalPath by replacing the "root" of the WebPath with the
MountPointand fixing the PathSeparators, the "intermediate" folders which are present in the WebPath will still be present in the constructed (wrong) LocalPath.The only way I can think of to solve this issue would be constructing the WebPath this way and then checking if the folder/file exists and removing intermediate path parts until the path points to a valid folder/file. Of course, this is not very elegant and takes away the feature of also working for nonexistent files/folders.
Maybe you can come up with a better solution, the missing information should be somewhere out there in the registry, shouldn't it?
The text was updated successfully, but these errors were encountered: