Propiedad de nombre completo de Excel con OneDrive

Solución universal y metaanálisis de todas las soluciones

TLDR :

• Para conocer la solución, salte a la sección Las Soluciones.

• Para el metanálisis, pase a la sección Pruebas y comparación de soluciones.

Fondo

@Cristian Buse y yo trabajamos extensamente en este problema después de probar todas las demás soluciones disponibles en línea y no encontrar ninguna de ellas universalmente precisa.

Al final, ambos creamos soluciones independientes:

• @Cristian Buse desarrolló su solución como parte de una de sus excelentes bibliotecas VBA, para ser específicos, la Biblioteca VBA-FileTools. Esta biblioteca también proporciona muchas otras funcionalidades muy útiles.

• Mi propia solución viene en forma de una función independiente sin dependencias. Esto es útil si este problema ocurre en un proyecto pequeño donde no se requiere funcionalidad adicional. Debido a que implementar la funcionalidad universal deseada es complejo, es muy largo y complicado para un solo procedimiento.

Las soluciones

NOTAS:

• Si encuentra algún error con nuestras soluciones, infórmelo aquí o en GitHub. En ese caso, le recomiendo que utilice esta solución mientras tanto, ya que es la siguiente solución más precisa disponible.

Solución 1 - Biblioteca

Importe esta biblioteca: VBA-FileTools de GitHub a su proyecto. Obtener el nombre local de su libro de trabajo es tan fácil como:

GetLocalPath(ThisWorkbook.FullName)

^{Notas:
Se agregó soporte completo para Mac a esta solución el 5 de abril de 2023.
Se agregó soporte para OneDrive versión 23.184.0903.0001 a esta solución el 25 de septiembre de 2023.}

Solución 2: función independiente

Copie esta función de GitHub Gist a cualquier módulo de código estándar.

Obtener el nombre local de su libro ahora funciona de la misma manera que con la Solución 1:

GetLocalPath(ThisWorkbook.FullName)

^{Notas:
Se agregó soporte parcial para Mac a esta solución el 20 de diciembre de 2022 y soporte completo el 20 de marzo de 2023.
Se agregó soporte para OneDrive versión 23.184.0903.0001 a esta solución el 2 de octubre de 2023.
Esta función también ofrece algunos parámetros opcionales , pero casi nunca deberían ser necesarios. (Consulte Gist para obtener más información)}

También puede copiar la función directamente desde aquí: ^{Acortada debido al límite de longitud de respuesta de 30 000 caracteres de StackOverflow.}

'Function for converting a OneDrive URL to the corresponding local path
'Algorithmically shortened code from here: 
'https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
'Author: Guido Witt-Dörring
Public Function GetLocalPath$(ByVal path$, Optional ByVal returnAll As Boolean = False, Optional ByVal preferredMountPointOwner$ = "", Optional ByVal rebuildCache As Boolean = False)
#If Mac Then
Const dp& = 70
Const ch$ = ".849C9593-D756-4E56-8D6E-42412F2A707B"
Const er As Boolean = True
Const ab$ = "/"
#Else
Const ab$ = "\"
Const er As Boolean = False
#End If
Const be$ = "GetLocalPath"
Const es& = 53
Const fl& = 7
Const fm& = 457
Const fn& = 325
Static ac As collection, et As Date
If Not Left(path, 8) = "https://" Then GetLocalPath = path: Exit Function
Dim r$, h$, b$, e
Dim dq$: dq = LCase$(preferredMountPointOwner)
If Not ac Is Nothing And Not rebuildCache Then
Dim bn As collection: Set bn = New collection
For Each e In ac
h = e(0): r = e(1)
If InStr(1, path, r, vbTextCompare) = 1 Then bn.Add Key:=e(2), Item:=Replace(Replace(path, r, h, , 1), "/", ab)
Next e
If bn.count > 0 Then
If returnAll Then
For Each e In bn: b = b & "//" & e: Next e
GetLocalPath = Mid$(b, 3): Exit Function
End If
On Error Resume Next: GetLocalPath = bn(dq): On Error GoTo 0
If GetLocalPath <> "" Then Exit Function
GetLocalPath = bn(1): Exit Function
End If
GetLocalPath = path
End If
Dim bg As collection: Set bg = New collection
Dim ax, ds$
#If Mac Then
Dim ci$, dt As Boolean
b = Environ("HOME")
ds = b & "/Library/Application Support/Microsoft/Office/CLP/"
b = Left$(b, InStrRev(b, "/Library/Containers/", , vbBinaryCompare))
bg.Add b & "Library/Containers/com.microsoft.OneDrive-mac/Data/Library/Application Support/OneDrive/settings/"
bg.Add b & "Library/Application Support/OneDrive/settings/"
ci = b & "Library/CloudStorage/"
#Else
bg.Add Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
ds = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
#End If
Dim a&
#If Mac Then
Dim ay(): ReDim ay(1 To bg.count * 11 + 1)
For Each ax In bg
For a = a + 1 To a + 9
ay(a) = ax & "Business" & a Mod 11
Next a
ay(a) = ax: a = a + 1
ay(a) = ax & "Personal"
Next ax
ay(a + 1) = ci
Dim du As Boolean
du = getsetting("GetLocalPath", "AccessRequestInfoMsg", "Displayed", "False") = "True"
If Not du Then MsgBox "The current VBA Project requires access to the OneDrive settings files to translate a OneDrive URL to the local path of the locally synchronized file/folder on your Mac. Because these files are located outside of Excels sandbox, file-access must be granted explicitly. Please approve the access requests following this message.", vbInformation
If Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be
#End If
Dim cz As collection: Set cz = New collection
For Each ax In bg
Dim g$: g = Dir(ax, vbDirectory)
Do Until g = vbNullString
If g = "Personal" Or g Like "Business#" Then cz.Add Item:=ax & g & ab
g = Dir(, vbDirectory)
Loop
Next ax
If Not ac Is Nothing Or er Then
Dim bf As collection: Set bf = New collection
Dim f
For Each f In cz
Dim t$: t = iif(f Like "*" & ab & "Personal" & ab, "????????????*", "????????-????-????-????-????????????")
Dim p$: p = Dir(f, vbNormal)
Do Until p = vbNullString
If p Like t & ".ini" Or p Like t & ".dat" Or p Like "ClientPolicy*.ini" Or StrComp(p, "GroupFolders.ini", vbTextCompare) = 0 Or StrComp(p, "global.ini", vbTextCompare) = 0 Or StrComp(p, "SyncEngineDatabase.db", vbTextCompare) = 0 Then bf.Add Item:=f & p
p = Dir
Loop
Next f
End If
If Not ac Is Nothing And Not rebuildCache Then
Dim at
For Each at In bf
If FileDateTime(at) > et Then rebuildCache = True: Exit For
Next at
If Not rebuildCache Then Exit Function
End If
Dim c&, am$, d() As Byte, i&, q&
Dim bp&, au() As Byte, ck$
Dim l() As Byte, ao$, aj() As Byte
Dim az() As Byte, bq$, av&
Dim y&, dx&, dy&
et = Now()
#If Mac Then
Dim z As collection: Set z = New collection
g = Dir(ci, vbDirectory)
Do Until g = vbNullString
If g Like "OneDrive*" Then
dt = True
f = ci & g & ab
at = ci & g & ab & ch
z.Add Item:=f
bf.Add Item:=f
bf.Add Item:=at
End If
g = Dir(, vbDirectory)
Loop
If ac Is Nothing Then
Dim da
If bf.count > 0 Then
ReDim da(1 To bf.count)
For a = 1 To UBound(da): da(a) = bf(a): Next a
If Not GrantAccessToMultipleFiles(da) Then Err.Raise dp, be
End If
End If
If dt Then
For a = z.count To 1 Step -1
Dim br&: br = 0
On Error Resume Next
br = GetAttr(z(a) & ch)
Dim bs As Boolean: bs = False
If Err.Number = 0 Then bs = Not CBool(br And vbDirectory)
On Error GoTo 0
If Not bs Then
g = Dir(z(a), vbDirectory)
Do Until g = vbNullString
If Not g Like ".Trash*" And g <> "Icon" Then
z.Add z(a) & g & ab
z.Add z(a) & g & ab & ch, z(a) & g & ab
End If
g = Dir(, vbDirectory)
Loop
z.Remove a
End If
Next a
If z.count > 0 Then
ReDim ay(1 To z.count)
For a = 1 To z.count: ay(a) = z(a): Next a
If Not GrantAccessToMultipleFiles(ay) Then Err.Raise dp, be
End If
On Error Resume Next
For a = z.count To 1 Step -1
z.Remove z(a)
Next a
On Error GoTo 0
Dim dz As collection
Set dz = New collection
For Each f In z
br = 0
On Error Resume Next
br = GetAttr(f & ch)
bs = False
If Err.Number = 0 Then bs = Not CBool(br And vbDirectory)
On Error GoTo 0
If bs Then
c = FreeFile(): b = "": at = f & ch
Dim ea As Boolean: ea = False
On Error GoTo ReadFailed
Open at For Binary Access Read As #c
ReDim d(0 To LOF(c)): Get c, , d: b = d
ea = True
ReadFailed: On Error GoTo -1
Close #c: c = 0
On Error GoTo 0
If ea Then
au = b
If LenB(b) > 0 Then
ReDim l(0 To LenB(b) * 2 - 1): q = 0
For i = LBound(au) To UBound(au)
l(q) = au(i): q = q + 2
Next i
b = l
Else: b = vbNullString
End If
Else
at = MacScript("return path to startup disk as string") & Replace(Mid$(at, 2), ab, ":")
b = MacScript("return read file """ & at & """ as string")
End If
If InStr(1, b, """guid"" : """, vbBinaryCompare) Then
b = Split(b, """guid"" : """)(1)
am = Left$(b, InStr(1, b, """", 0) - 1)
dz.Add Key:=am, Item:=VBA.Array(am, Left$(f, Len(f) - 1))
Else
Debug.Print "Warning, empty syncIDFile encountered!"
End If
End If
Next f
End If
If Not du Then savesetting "GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"
#End If
Dim j, w$(), s&, cl$
Dim db$, dc$, cm$, bj$
Dim aa$, ak$, aq$
Dim bx$, ew$, by As Boolean
Dim bz$, ca$, dd$, ex$
Dim ey$, af$, ez$
Dim fa$: fa = chrb$(2)
Dim eb As String * 4: MidB$(eb, 1) = chrb$(1)
Dim ec$: ec = chrb$(0)
#If Mac Then
Const ed$ = vbNullChar & vbNullChar
#Else
Const ed$ = vbNullChar
#End If
Dim cn As collection, fd As Date
Set cn = New collection
Set ac = New collection
For Each f In cz
g = Mid$(f, InStrRev(f, ab, Len(f) - 1, 0) + 1)
g = Left$(g, Len(g) - 1)
If Dir(f & "global.ini", vbNormal) = "" Then GoTo NextFolder
c = FreeFile()
Open f & "global.ini" For Binary Access Read As #c
ReDim d(0 To LOF(c)): Get c, , d
Close #c: c = 0
#If Mac Then
bq = d: GoSub DecodeUTF8
d = ao
#End If
For Each j In Split(d, vbNewLine)
If j Like "cid = *" Then t = Mid$(j, 7): Exit For
Next j
If t = vbNullString Then GoTo NextFolder
If (Dir(f & t & ".ini") = vbNullString Or (Dir(f & "SyncEngineDatabase.db") = vbNullString And Dir(f & t & ".dat") = vbNullString)) Then GoTo NextFolder
If g Like "Business#" Then
bx = Replace(Space$(32), " ", "[a-f0-9]") & "*"
ElseIf g = "Personal" Then
bx = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"
End If
p = Dir(ds, vbNormal)
Do Until p = vbNullString
a = InStrRev(p, t, , vbTextCompare)
If a > 1 And t <> vbNullString Then bj = LCase$(Left$(p, a - 2)): Exit Do
p = Dir
Loop
#If Mac Then
On Error Resume Next
fd = cn(g)
by = (Err.Number = 0)
On Error GoTo 0
If by Then
If FileDateTime(f & t & ".ini") < fd Then
GoTo NextFolder
Else
For a = ac.count To 1 Step -1
If ac(a)(5) = g Then
ac.Remove a
End If
Next a
cn.Remove g
cn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")
End If
Else
cn.Add Key:=g, Item:=FileDateTime(f & t & ".ini")
End If
#End If
Dim ba As collection: Set ba = New collection
p = Dir(f, vbNormal)
Do Until p = vbNullString
If p Like "ClientPolicy*.ini" Then
c = FreeFile()
Open f & p For Binary Access Read As #c
ReDim d(0 To LOF(c)): Get c, , d
Close #c: c = 0
#If Mac Then
bq = d: GoSub DecodeUTF8
d = ao
#End If
ba.Add Key:=p, Item:=New collection
For Each j In Split(d, vbNewLine)
If InStr(1, j, " = ", vbBinaryCompare) Then
db = Left$(j, InStr(1, j, " = ", 0) - 1)
b = Mid$(j, InStr(1, j, " = ", 0) + 3)
Select Case db
Case "DavUrlNamespace"
ba(p).Add Key:=db, Item:=b
Case "SiteID", "IrmLibraryId", "WebID"
b = Replace(LCase$(b), "-", "")
If Len(b) > 3 Then b = Mid$(b, 2, Len(b) - 2)
ba(p).Add Key:=db, Item:=b
End Select
End If
Next j
End If
p = Dir
Loop
Dim x As collection: Set x = Nothing
If Dir(f & t & ".dat") = vbNullString Then GoTo Continue
Const fs& = 1000
Const cp& = 255
Dim bb&: bb = -1
Try: On Error GoTo Catch
Set x = New collection
Dim cq&: cq = 1
Dim cr As Date: cr = FileDateTime(f & t & ".dat")
a = 0
Do
If FileDateTime(f & t & ".dat") > cr Then GoTo Try
c = FreeFile
Open f & t & ".dat" For Binary Access Read As #c
Dim df&: df = LOF(c)
If bb = -1 Then bb = df
ReDim d(0 To bb + fs)
Get c, cq, d: b = d
Dim cs&: cs = LenB(b)
Close #c: c = 0
cq = cq + bb
For e = 16 To 8 Step -8
a = InStrB(e + 1, b, eb, 0)
Do While a > e And a < cs - 168
If StrComp(MidB$(b, a - e, 1), fa, 0) = 0 Then
a = a + 8: s = InStrB(a, b, ec, 0) - a
If s < 0 Then s = 0
If s > 39 Then s = 39
#If Mac Then
ck = MidB$(b, a, s)
GoSub DecodeANSI: ak = ao
#Else
ak = StrConv(MidB$(b, a, s), vbUnicode)
#End If
a = a + 39: s = InStrB(a, b, ec, 0) - a
If s < 0 Then s = 0
If s > 39 Then s = 39
#If Mac Then
ck = MidB$(b, a, s)
GoSub DecodeANSI: aa = ao
#Else
aa = StrConv(MidB$(b, a, s), vbUnicode)
#End If
a = a + 121
s = InStr(-Int(-(a - 1) / 2) + 1, b, ed, 0) * 2 - a - 1
If s > cp * 2 Then s = cp * 2
If s < 0 Then s = 0
If ak Like bx And aa Like bx Then
#If Mac Then
Do While s Mod 4 > 0
If s > cp * 4 Then Exit Do
s = InStr(-Int(-(a + s) / 2) + 1, b, ed, 0) * 2 - a - 1
Loop
If s > cp * 4 Then s = cp * 4
aj = MidB$(b, a, s)
ReDim l(LBound(aj) To UBound(aj))
i = LBound(aj): q = LBound(aj)
Do While i < UBound(aj)
If aj(i + 2) + aj(i + 3) = 0 Then
l(q) = aj(i)
l(q + 1) = aj(i + 1)
q = q + 2
Else
If aj(i + 3) <> 0 Then Err.Raise fn, be
y = aj(i + 2) * &H10000 + aj(i + 1) * &H100& + aj(i)
bp = y - &H10000
dy = &HD800& Or (bp \ &H400&)
dx = &HDC00& Or (bp And &H3FF)
l(q) = dy And &HFF&
l(q + 1) = dy \ &H100&
l(q + 2) = dx And &HFF&
l(q + 3) = dx \ &H100&
q = q + 4
End If
i = i + 4
Loop
If q > LBound(l) Then
ReDim Preserve l(LBound(l) To q - 1)
aq = l
Else: aq = vbNullString
End If
#Else
aq = MidB$(b, a, s)
#End If
x.Add VBA.Array(aa, aq), ak
End If
End If
a = InStrB(a + 1, b, eb, 0)
Loop
If x.count > 0 Then Exit For
Next e
Loop Until cq >= df Or bb >= df
GoTo Continue
Catch:
Select Case Err.Number
Case fm
x.Remove ak
Resume
Case Is <> fl: Err.Raise Err, be
End Select
If bb > &HFFFFF Then bb = bb / 2: Resume Try
Err.Raise Err, be
Continue:
On Error GoTo 0
If Not x Is Nothing Then GoTo SkipDbFile
c = FreeFile()
Open f & "SyncEngineDatabase.db" For Binary Access Read As #c
cs = LOF(c)
If cs = 0 Then GoTo CloseFile
Dim ee$: ee = chrw$(&H808)
Const fx& = 8
Const fy& = -3
Const fg As Byte = 9
Const fh& = 6
Const fz& = &H16
Const ga& = &H15
Const cc& = -16
Const dj& = -15
Const ef& = &H100000
Dim bk&, cd&, bc&
Dim ag(1 To 4) As Byte
Dim an$, dk$
Dim eg&
Dim eh&
Dim ei&, dl&
Dim ej As Byte, ek As Byte
Dim el As Boolean
cr = 0
ReDim d(1 To ef)
Do
a = 0
If FileDateTime(f & "SyncEngineDatabase.db") > cr Then
Set x = New collection
Dim dm As collection: Set dm = New collection
cr = FileDateTime(f & "SyncEngineDatabase.db")
bk = 1
an = vbNullString
End If
If LenB(an) > 0 Then
aq = MidB$(b, eg, eh)
End If
Get c, bk, d
b = d
a = InStrB(1 - cc, b, ee, vbBinaryCompare)
dl = 0
Do While a > 0
If a + cc - 2 > dl And LenB(an) > 0 Then
If dl > 0 Then
aq = MidB$(b, eg, eh)
End If
bq = aq: GoSub DecodeUTF8
aq = ao
On Error Resume Next
x.Add VBA.Array(dk, aq), an
If Err.Number <> 0 Then
If dm(an) < ek Then
If x(an)(1) <> aq Or x(an)(0) <> dk Then
x.Remove an
dm.Remove an
x.Add VBA.Array(dk, aq), an
End If
End If
End If
dm.Add ek, an
On Error GoTo 0
an = vbNullString
End If
If d(a + fy) <> fx Then GoTo NextSig
el = True
If d(a + dj) = ga Then
i = a + dj
ElseIf d(a + cc) = fz Then
i = a + cc
el = False
ElseIf d(a + dj) <= fg Then
i = a + dj
Else
GoTo NextSig
End If
ej = d(i)
cd = fh
For q = 1 To 4
If q = 1 And ej <= fg Then
ag(q) = d(i + 2)
Else
ag(q) = d(i + q)
End If
If ag(q) < 37 Or ag(q) Mod 2 = 0 Then GoTo NextSig
ag(q) = (ag(q) - 13) / 2
cd = cd + ag(q)
Next q
If el Then
bc = d(i + 5)
If bc < 15 Or bc Mod 2 = 0 Then GoTo NextSig
bc = (bc - 13) / 2
Else
bc = (d(i + 5) - 128) * 64 + (d(i + 6) - 13) / 2
If bc < 1 Or d(i + 6) Mod 2 = 0 Then GoTo NextSig
End If
cd = cd + bc
ei = a + cd - 1
If ei > ef Then
a = a - 1
Exit Do
End If
i = a + fh
#If Mac Then
ck = MidB$(b, i, ag(1))
GoSub DecodeANSI: ak = ao
#Else
ak = StrConv(MidB$(b, i, ag(1)), vbUnicode)
#End If
i = i + ag(1)
aa = StrConv(MidB$(b, i, ag(2)), vbUnicode)
#If Mac Then
ck = MidB$(b, i, ag(2))
GoSub DecodeANSI: aa = ao
#Else
aa = StrConv(MidB$(b, i, ag(2)), vbUnicode)
#End If
If ak Like bx And aa Like bx Then
eg = i + ag(2) + ag(3) + ag(4)
eh = bc
an = Left(ak, 32)
dk = Left(aa, 32)
ek = ej
dl = ei
End If
NextSig:
a = InStrB(a + 1, b, ee, vbBinaryCompare)
Loop
If a = 0 Then
bk = bk + ef + cc
Else
bk = bk + a + cc
End If
Loop Until bk > cs
CloseFile:
Close #c
SkipDbFile:
c = FreeFile()
Open f & t & ".ini" For Binary Access Read As #c
ReDim d(0 To LOF(c)): Get c, , d
Close #c: c = 0
#If Mac Then
bq = d: GoSub DecodeUTF8:
d = ao
#End If
Select Case True
Case g Like "Business#"
Dim em As collection: Set em = New collection
dc = vbNullString
For Each j In Split(d, vbNewLine)
r = "": h = "": w = Split(j, """")
Select Case Left$(j, InStr(1, j, " = ", 0) - 1)
Case "libraryScope"
h = w(9)
af = h: am = Split(w(10), " ")(2)
cl = Split(j, " ")(2)
ew = w(3): w = Split(w(8), " ")
bz = w(1): dd = w(2): ca = w(3)
If dc = vbNullString Or ew = "ODB" Then
dc = h: p = "ClientPolicy.ini"
ey = am: ez = af
Else: p = "ClientPolicy_" & ca & bz & ".ini"
End If
On Error Resume Next
r = ba(p)("DavUrlNamespace")
On Error GoTo 0
If r = "" Then
For Each e In ba
If e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then
r = e("DavUrlNamespace"): Exit For
End If
Next e
End If
If r = vbNullString Then Err.Raise es, be
em.Add VBA.Array(cl, r), cl
If Not h = vbNullString Then ac.Add VBA.Array(h, r, bj, am, af, g), Key:=h
Case "libraryFolder"
cl = Split(j, " ")(3)
h = w(1): af = h
am = Split(w(4), " ")(1)
b = vbNullString: aa = Left$(Split(j, " ")(4), 32)
Do
On Error Resume Next: x aa
by = (Err.Number = 0): On Error GoTo 0
If Not by Then Exit Do
b = x(aa)(1) & "/" & b
aa = x(aa)(0)
Loop
r = em(cl)(1) & b
ac.Add VBA.Array(h, r, bj, am, af, g), h
Case "AddedScope"
cm = w(5): If cm = " " Then cm = ""
w = Split(w(4), " "): bz = w(1)
dd = w(2): ca = w(3): ex = w(4)
p = "ClientPolicy_" & ca & bz & ex & ".ini"
On Error Resume Next
r = ba(p)("DavUrlNamespace") & cm
On Error GoTo 0
If r = "" Then
For Each e In ba
If e("SiteID") = bz And e("WebID") = dd And e("IrmLibraryId") = ca Then
r = e("DavUrlNamespace") & cm
Exit For
End If
Next e
End If
If r = vbNullString Then Err.Raise es, be
b = vbNullString: aa = Left$(Split(j, " ")(3), 32)
Do
On Error Resume Next: x aa
by = (Err.Number = 0): On Error GoTo 0
If Not by Then Exit Do
b = x(aa)(1) & ab & b
aa = x(aa)(0)
Loop
h = dc & ab & b
ac.Add VBA.Array(h, r, bj, ey, ez, g), h
Case Else: Exit For
End Select
Next j
Case g = "Personal"
For Each j In Split(d, vbNewLine)
If j Like "library = *" Then
w = Split(j, """"): h = w(3)
af = h: am = Split(w(4), " ")(2)
Exit For
End If
Next j
On Error Resume Next
r = ba("ClientPolicy.ini")("DavUrlNamespace")
On Error GoTo 0
If h = "" Or r = "" Or t = "" Then GoTo NextFolder
ac.Add VBA.Array(h, r & "/" & t, bj, am, af, g), Key:=h
If Dir(f & "GroupFolders.ini") = "" Then GoTo NextFolder
t = vbNullString: c = FreeFile()
Open f & "GroupFolders.ini" For Binary Access Read As #c
ReDim d(0 To LOF(c)): Get c, , d
Close #c: c = 0
#If Mac Then
bq = d: GoSub DecodeUTF8
d = ao
#End If
For Each j In Split(d, vbNewLine)
If j Like "*_BaseUri = *" And t = vbNullString Then
t = LCase$(Mid$(j, InStrRev(j, "/", , 0) + 1, InStrRev(j, "!", , 0) - InStrRev(j, "/", , 0) - 1))
ak = Left$(j, InStr(1, j, "_", 0) - 1)
ElseIf t <> vbNullString Then
ac.Add VBA.Array(h & ab & x(ak)(1), r & "/" & t & "/" & Mid$(j, Len(ak) + 9), bj, am, af, g), Key:=h & ab & x(ak)(1)
t = vbNullString: ak = vbNullString
End If
Next j
End Select
NextFolder:
t = vbNullString: b = vbNullString: bj = vbNullString
Next f
Dim ce As collection: Set ce = New collection
For Each e In ac
h = e(0): r = e(1): af = e(4)
If Right$(r, 1) = "/" Then r = Left$(r, Len(r) - 1)
If Right$(h, 1) = ab Then h = Left$(h, Len(h) - 1)
If Right$(af, 1) = ab Then af = Left$(af, Len(af) - 1)
ce.Add VBA.Array(h, r, e(2), e(3), af), h
Next e
Set ac = ce
#If Mac Then
If dt Then
Set ce = New collection
For Each e In ac
h = e(0): am = e(3): af = e(4)
h = Replace(h, af, dz(am)(1), , 1)
ce.Add VBA.Array(h, e(1), e(2)), h
Next e
Set ac = ce
End If
#End If
GetLocalPath = GetLocalPath(path, returnAll, dq, False): Exit Function
Exit Function
DecodeUTF8:
Const cf As Boolean = False
Dim u&, m&, bl&
Static cg(0 To 255) As Byte
Static fj&(2 To 4)
Static dn&(2 To 4)
If cg(0) = 0 Then
For u = &H0& To &H7F&: cg(u) = 1: Next u
For u = &HC2& To &HDF&: cg(u) = 2: Next u
For u = &HE0& To &HEF&: cg(u) = 3: Next u
For u = &HF0& To &HF4&: cg(u) = 4: Next u
For u = 2 To 4: fj(u) = (2 ^ (7 - u) - 1): Next u
dn(2) = &H80&: dn(3) = &H800&: dn(4) = &H10000
End If
Dim en As Byte
az = bq
ReDim l(0 To (UBound(az) - LBound(az) + 1) * 2)
m = 0
u = LBound(az)
Do While u <= UBound(az)
y = az(u)
av = cg(y)
If av = 0 Then
If cf Then Err.Raise 5
GoTo insertErrChar
ElseIf av = 1 Then
l(m) = y
m = m + 2
ElseIf u + av - 1 > UBound(az) Then
If cf Then Err.Raise 5
GoTo insertErrChar
Else
y = az(u) And fj(av)
For bl = 1 To av - 1
en = az(u + bl)
If (en And &HC0&) = &H80& Then
y = (y * &H40&) + (en And &H3F)
Else
If cf Then Err.Raise 5
GoTo insertErrChar
End If
Next bl
If y < dn(av) Then
If cf Then Err.Raise 5
GoTo insertErrChar
ElseIf y < &HD800& Then
l(m) = CByte(y And &HFF&)
l(m + 1) = CByte(y \ &H100&)
m = m + 2
ElseIf y < &HE000& Then
If cf Then Err.Raise 5
GoTo insertErrChar
ElseIf y < &H10000 Then
If y = &HFEFF& Then GoTo nextCp
l(m) = y And &HFF&
l(m + 1) = y \ &H100&
m = m + 2
ElseIf y < &H110000 Then
bp = y - &H10000
Dim eo&: eo = &HDC00& Or (bp And &H3FF)
Dim ep&: ep = &HD800& Or (bp \ &H400&)
l(m) = ep And &HFF&
l(m + 1) = ep \ &H100&
l(m + 2) = eo And &HFF&
l(m + 3) = eo \ &H100&
m = m + 4
Else
If cf Then Err.Raise 5
insertErrChar: l(m) = &HFD
l(m + 1) = &HFF
m = m + 2
If av = 0 Then av = 1
End If
End If
nextCp: u = u + av
Loop
ao = MidB$(l, 1, m)
Return
DecodeANSI:
au = ck
m = UBound(au) - LBound(au) + 1
If m > 0 Then
ReDim l(0 To m * 2 - 1): bl = 0
For m = LBound(au) To UBound(au)
l(bl) = au(m): bl = bl + 2
Next m
ao = l
Else
ao = vbNullString
End If
Return
End Function

¿Cómo funcionan las soluciones?

Ambas soluciones obtienen toda la información necesaria para traducir la URL de OneDrive a una ruta local desde los archivos de configuración de OneDrive dentro del directorio %localappdata%\Microsoft\OneDrive\settings\....

Se pueden leer los siguientes archivos:

(Comodines: *- cero o más caracteres; ?- un carácter)

????????????????.dat
????????????????.ini
global.ini
GroupFolders.ini
????????-????-????-????-????????????.dat
????????-????-????-????-????????????.ini
ClientPolicy*.ini
SyncEngineDatabase.db

Los datos de todos estos archivos se utilizan para crear un "diccionario" de todos los puntos de montaje locales en su PC y su correspondiente URL raíz de OneDrive. Por ejemplo, para su OneDrive personal, un punto de montaje local podría verse así: C:\Users\Username\OneDrivey la raíz URL correspondiente podría verse así: https://d.docs.live.net/f9d8c1184686d493.

Para obtener más información sobre cómo se construye y utiliza exactamente el diccionario, consulte los comentarios extensos sobre el código en la esencia de la función independiente y los recursos vinculados allí.

Pruebas y comparación de soluciones

Realicé pruebas exhaustivas de todas las soluciones que pude encontrar en línea. Aquí se presentará una selección de estas pruebas.

Esta es una lista de algunas de las soluciones probadas:

Cada línea de la tabla de la imagen siguiente representa una solución en la tabla anterior y se pueden correlacionar mediante el número de solución.
Del mismo modo, cada columna representa un caso de prueba; se pueden correlacionar con esta tabla de prueba utilizando el número de prueba. Desafortunadamente, Stack Overflow no permite respuestas lo suficientemente largas como para incluir la tabla de casos de prueba directamente en esta publicación.

^{Todas estas pruebas se realizaron en Windows. En macOS, todas las soluciones, excepto la número 32 y la número 33 , pasarían las pruebas 0/46. Las soluciones presentadas en esta publicación (n.° 32 y n.° 33) también pasan todas las pruebas en macOS.}

La mayoría de las soluciones pasan muy pocas pruebas. Muchas de estas pruebas son relativamente difíciles de resolver, algunas son casos extremos absolutos, como las pruebas N.° 41 a 46, que prueban cómo una solución maneja las carpetas de OneDrive que están sincronizadas con múltiples rutas locales diferentes, lo que solo puede suceder si hay múltiples Business OneDrive. Las cuentas inician sesión en la misma PC e incluso entonces necesitan alguna configuración especial. (Puede encontrar más información al respecto aquí en el hilo 2 )

La prueba número 22 contiene varios caracteres emoji Unicode en algunos nombres de carpetas, es por eso que muchas soluciones fallan con errores aquí.

Si tienes otra solución diferente que te gustaría que probara, házmelo saber y la agregaré a esta sección.

Sep 02 '2022 01:09 GWD