Get URL for file stored in OneDrive with Excel VBA

Question

My Exel VBA saves a pdf file to OneDrive locally "C:\Users\Name\OneDrive\FileName.pdf". I need to find some code that gives med the URL to this file, so that it can be typed into a cell. The URL is used to create a QR code, so that anyone can read the pdf-file.

For now I have to find the URL manually and paste it in to the spreadsheet, before VBA creates the QR-code. I am working in Office 365, but the .xlsm-file will be distributed to user with different Excel versions. I've been struggling with this for a while, so I'm very happy if anyone can help.

CODE:
Sub QrLabelCreate()

'STEP 1:
'Excel VBA put data into a word-document, and export it to pdf-file (saved to OneDrive):
        .ActiveDocument.ExportAsFixedFormat _
        OutputFileName:="C:Users\Name\OneDrive\MyMap\" & ID & ".pdf", _
        ExportFormat:=wdExportFormatPDF
        
'STEP 2: THE PROBLEM
'====== I am not able to create code that gives me the URL to the pdf-file. ==========


'STEP 3:
'The URL is pasted into the spreadsheet, and  VBA creates the QR-code.

End Sub

Answer 1

Doing this generally is not easy at all, but luckily it is related to the more common problem of finding the local path when given the URL.

That's why I can now offer a kind of solution here.

Note that this solution does not create a OneDrive 'share' link, to create such a link you need to use the Microsoft Graph API! The links created by this function will only work for the account that owns the remote folder that's being synchronized.

To use my solution, copy the following function into any standard code module:

'Function for converting OneDrive/SharePoint Local Paths synchronized to
'OneDrive in any way to an OneDrive/SharePoint URL, containing for example
'.sharepoint.com/sites, my.sharepoint.com/personal/, or https://d.docs.live.net/
'depending on the type of OneDrive account and synchronization.
'If no url path can be found, the input value will be returned unmodified.
'Author: Guido Witt-Dörring
'Source: https://gist.github.com/guwidoe/6f0cbcd22850a360c623f235edd2dce2
Public Function GetWebPath(ByVal path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
Const vbErrPermissionDenied         As Long = 70
Const noErrJustDecodeUTF8             As Long = 20
Const syncIDFileName As String = ".849C9593-D756-4E56-8D6E-42412F2A707B"
Const isMac As Boolean = True
Const ps As String = "/"
#Else
Const ps As String = "\"
Const isMac As Boolean = False
#End If
Const methodName As String = "GetWebPath"
Const vbErrFileNotFound             As Long = 53
Const vbErrOutOfMemory               As Long = 7
Const vbErrKeyAlreadyExists         As Long = 457
Const vbErrInvalidFormatInResourceFile As Long = 325

Static locToWebColl As Collection, lastCacheUpdate As Date

If path Like "http*" Then GetWebPath = path: Exit Function

Dim webRoot As String, locRoot As String, vItem As Variant
Dim s As String, keyExists As Boolean
If Not locToWebColl Is Nothing And Not rebuildCache Then
locRoot = path: GetWebPath = ""
If locRoot Like "*" & ps Then locRoot = Left(locRoot, Len(locRoot) - 1)
Do
On Error Resume Next: locToWebColl locRoot: keyExists = _
(Err.number = 0): On Error GoTo 0
If keyExists Or InStr(locRoot, ps) = 0 Then Exit Do
locRoot = Left(locRoot, InStrRev(locRoot, ps) - 1)
Loop
If InStr(locRoot, ps) > 0 Then _
GetWebPath = Replace(Replace(path, locRoot, _
locToWebColl(locRoot)(1), , 1), ps, "/"): Exit Function
GetWebPath = path
End If

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

#Else
settPaths.Add Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
clpPath = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
#End If

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

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

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

If Not locToWebColl Is Nothing And Not rebuildCache Then
Dim vFile As Variant
For Each vFile In requiredFiles
If FileDateTime(vFile) > lastCacheUpdate Then _
rebuildCache = True: Exit For
Next vFile
If Not rebuildCache Then Exit Function
End If

Dim fileNum As Long, syncID As String, b() As Byte, j As Long, k As Long
Dim m As Long, ansi() As Byte, sAnsi As String
Dim utf16() As Byte, sUtf16 As String, utf32() As Byte
Dim utf8() As Byte, sUtf8 As String, numBytesOfCodePoint As Long
Dim codepoint As Long, lowSurrogate As Long, highSurrogate As Long

lastCacheUpdate = Now()
#If Mac Then
Dim coll As Collection: Set coll = New Collection
dirName = Dir(cloudStoragePath, vbDirectory)
Do Until dirName = vbNullString
If dirName Like "OneDrive*" Then
cloudStoragePathExists = True
vDir = cloudStoragePath & dirName & ps
vFile = cloudStoragePath & dirName & ps & syncIDFileName
coll.Add Item:=vDir
requiredFiles.Add Item:=vDir
requiredFiles.Add Item:=vFile
End If
dirName = Dir(, vbDirectory)
Loop

If locToWebColl Is Nothing Then
Dim vFiles As Variant
If requiredFiles.count > 0 Then
ReDim vFiles(1 To requiredFiles.count)
For i = 1 To UBound(vFiles): vFiles(i) = requiredFiles(i): Next i
If Not GrantAccessToMultipleFiles(vFiles) Then _
Err.Raise vbErrPermissionDenied, methodName
End If
End If

If cloudStoragePathExists Then
For i = coll.count To 1 Step -1
Dim fAttr As Long: fAttr = 0
On Error Resume Next
fAttr = GetAttr(coll(i) & syncIDFileName)
Dim IsFile As Boolean: IsFile = False
If Err.number = 0 Then IsFile = Not CBool(fAttr And vbDirectory)
On Error GoTo 0
If Not IsFile Then
dirName = Dir(coll(i), vbDirectory)
Do Until dirName = vbNullString
If Not dirName Like ".Trash*" And dirName <> "Icon" Then
coll.Add coll(i) & dirName & ps
coll.Add coll(i) & dirName & ps & syncIDFileName, _
coll(i) & dirName & ps
End If
dirName = Dir(, vbDirectory)
Loop
coll.Remove i
End If
Next i
If coll.count > 0 Then
ReDim arrDirs(1 To coll.count)
For i = 1 To coll.count: arrDirs(i) = coll(i): Next i
If Not GrantAccessToMultipleFiles(arrDirs) Then _
Err.Raise vbErrPermissionDenied, methodName
End If
On Error Resume Next
For i = coll.count To 1 Step -1
coll.Remove coll(i)
Next i
On Error GoTo 0

Dim syncIDtoSyncDir As Collection
Set syncIDtoSyncDir = New Collection
For Each vDir In coll
fAttr = 0
On Error Resume Next
fAttr = GetAttr(vDir & syncIDFileName)
IsFile = False
If Err.number = 0 Then IsFile = Not CBool(fAttr And vbDirectory)
On Error GoTo 0
If IsFile Then
fileNum = FreeFile(): s = "": vFile = vDir & syncIDFileName
Dim readSucceeded As Boolean: readSucceeded = False
On Error GoTo ReadFailed
Open vFile For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b: s = b
readSucceeded = True
ReadFailed:          On Error GoTo -1
Close #fileNum: fileNum = 0
On Error GoTo 0
If readSucceeded Then
ansi = s
If LenB(s) > 0 Then
ReDim utf16(0 To LenB(s) * 2 - 1): k = 0
For j = LBound(ansi) To UBound(ansi)
utf16(k) = ansi(j): k = k + 2
Next j
s = utf16
Else: s = vbNullString
End If
Else
vFile = MacScript("return path to startup disk as " & _
"string") & Replace(Mid$(vFile, 2), ps, ":")
s = MacScript("return read file """ & _
vFile & """ as string")
End If
If InStr(1, s, """guid"" : """, vbBinaryCompare) Then
s = Split(s, """guid"" : """)(1)
syncID = Left$(s, InStr(1, s, """", 0) - 1)
syncIDtoSyncDir.Add Key:=syncID, _
Item:=VBA.Array(syncID, Left$(vDir, Len(vDir) - 1))
Else
Debug.Print "Warning, empty syncIDFile encountered!"
End If
End If
Next vDir
End If
If Not accessRequestInfoMsgShown Then SaveSetting _
"GetLocalPath", "AccessRequestInfoMsg", "Displayed", "True"
#End If

Dim line As Variant, parts() As String, n As Long, libNr As String
Dim tag As String, mainMount As String, relPath As String, email As String
Dim parentID As String, folderID As String, folderName As String
Dim idPattern As String, folderType As String
Dim siteID As String, libID As String, webID As String, lnkID As String
Dim mainSyncID As String, syncFind As String, mainSyncFind As String
Dim sig1 As String:    sig1 = ChrB$(2)
Dim sig2 As String * 4:   MidB$(sig2, 1) = ChrB$(1)
Dim vbNullByte As String: vbNullByte = ChrB$(0)
#If Mac Then
Const sig3 As String = vbNullChar & vbNullChar
#Else
Const sig3 As String = vbNullChar
#End If

Dim lastAccountUpdates As Collection, lastAccountUpdate As Date
Set lastAccountUpdates = New Collection
Set locToWebColl = New Collection
For Each vDir In oneDriveSettDirs
dirName = Mid$(vDir, InStrRev(vDir, ps, Len(vDir) - 1, 0) + 1)
dirName = Left$(dirName, Len(dirName) - 1)

If Dir(vDir & "global.ini", vbNormal) = "" Then GoTo NextFolder
fileNum = FreeFile()
Open vDir & "global.ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
sUtf8 = b: GoSub DecodeUTF8
b = sUtf16
#End If
For Each line In Split(b, vbNewLine)
If line Like "cid = *" Then cID = Mid$(line, 7): Exit For
Next line

If cID = vbNullString Then GoTo NextFolder
If (Dir(vDir & cID & ".ini") = vbNullString Or _
(Dir(vDir & "SyncEngineDatabase.db") = vbNullString And _
Dir(vDir & cID & ".dat") = vbNullString)) Then GoTo NextFolder
If dirName Like "Business#" Then
idPattern = Replace(Space$(32), " ", "[a-f0-9]") & "*"
ElseIf dirName = "Personal" Then
idPattern = Replace(Space$(12), " ", "[A-F0-9]") & "*!###*"
End If

fileName = Dir(clpPath, vbNormal)
Do Until fileName = vbNullString
i = InStrRev(fileName, cID, , vbTextCompare)
If i > 1 And cID <> vbNullString Then _
email = LCase$(Left$(fileName, i - 2)): Exit Do
fileName = Dir
Loop

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

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

Dim odFolders As Collection: Set odFolders = Nothing
If Dir(vDir & cID & ".dat") = vbNullString Then GoTo Continue

Const chunkOverlap        As Long = 1000
Const maxDirName            As Long = 255
Dim buffSize As Long: buffSize = -1
Try:    On Error GoTo Catch
Set odFolders = New Collection
Dim lastChunkEndPos As Long: lastChunkEndPos = 1
Dim lastFileUpdate As Date:  lastFileUpdate = FileDateTime(vDir & _
cID & ".dat")
i = 0
Do
If FileDateTime(vDir & cID & ".dat") > lastFileUpdate Then GoTo Try
fileNum = FreeFile
Open vDir & cID & ".dat" For Binary Access Read As #fileNum
Dim lenDatFile As Long: lenDatFile = LOF(fileNum)
If buffSize = -1 Then buffSize = lenDatFile
ReDim b(0 To buffSize + chunkOverlap)
Get fileNum, lastChunkEndPos, b: s = b
Dim size As Long: size = LenB(s)
Close #fileNum: fileNum = 0
lastChunkEndPos = lastChunkEndPos + buffSize

For vItem = 16 To 8 Step -8
i = InStrB(vItem + 1, s, sig2, 0)
Do While i > vItem And i < size - 168
If StrComp(MidB$(s, i - vItem, 1), sig1, 0) = 0 Then
i = i + 8: n = InStrB(i, s, vbNullByte, 0) - i
If n < 0 Then n = 0
If n > 39 Then n = 39
#If Mac Then
sAnsi = MidB$(s, i, n)
GoSub DecodeANSI: folderID = sUtf16
#Else
folderID = StrConv(MidB$(s, i, n), vbUnicode)
#End If
i = i + 39: n = InStrB(i, s, vbNullByte, 0) - i
If n < 0 Then n = 0
If n > 39 Then n = 39
#If Mac Then
sAnsi = MidB$(s, i, n)
GoSub DecodeANSI: parentID = sUtf16
#Else
parentID = StrConv(MidB$(s, i, n), vbUnicode)
#End If
i = i + 121
n = InStr(-Int(-(i - 1) / 2) + 1, s, sig3) * 2 - i - 1
If n > maxDirName * 2 Then n = maxDirName * 2
If n < 0 Then n = 0
If folderID Like idPattern _
And parentID Like idPattern Then
#If Mac Then
Do While n Mod 4 > 0
If n > maxDirName * 4 Then Exit Do
n = InStr(-Int(-(i + n) / 2) + 1, s, sig3) _
* 2 - i - 1
Loop
If n > maxDirName * 4 Then n = maxDirName * 4
utf32 = MidB$(s, i, n)
ReDim utf16(LBound(utf32) To UBound(utf32))
j = LBound(utf32): k = LBound(utf32)
Do While j < UBound(utf32)
If utf32(j + 2) + utf32(j + 3) = 0 Then
utf16(k) = utf32(j)
utf16(k + 1) = utf32(j + 1)
k = k + 2
Else
If utf32(j + 3) <> 0 Then Err.Raise _
vbErrInvalidFormatInResourceFile, _
methodName
codepoint = utf32(j + 2) * &H10000 + _
utf32(j + 1) * &H100& + _
utf32(j)
m = codepoint - &H10000
highSurrogate = &HD800& Or (m \ &H400&)
lowSurrogate = &HDC00& Or (m And &H3FF)
utf16(k) = highSurrogate And &HFF&
utf16(k + 1) = highSurrogate \ &H100&
utf16(k + 2) = lowSurrogate And &HFF&
utf16(k + 3) = lowSurrogate \ &H100&
k = k + 4
End If
j = j + 4
Loop
If k > LBound(utf16) Then
ReDim Preserve utf16(LBound(utf16) To k - 1)
folderName = utf16
Else: folderName = vbNullString
End If
#Else
folderName = MidB$(s, i, n)
#End If
odFolders.Add VBA.Array(parentID, folderName), _
folderID
End If
End If
i = InStrB(i + 1, s, sig2, 0)
Loop
If odFolders.count > 0 Then Exit For
Next vItem
Loop Until lastChunkEndPos >= lenDatFile _
Or buffSize >= lenDatFile
GoTo Continue
Catch:
Select Case Err.number
Case vbErrKeyAlreadyExists
odFolders.Remove folderID
Resume
Case Is <> vbErrOutOfMemory: Err.Raise Err, methodName
End Select
If buffSize > &HFFFFF Then buffSize = buffSize / 2: Resume Try
Err.Raise Err, methodName
Continue:
On Error GoTo 0
If Not odFolders Is Nothing Then GoTo SkipDbFile
fileNum = FreeFile()
Open vDir & "SyncEngineDatabase.db" For Binary Access Read As #fileNum
size = LOF(fileNum)
If size = 0 Then GoTo CloseFile
Dim sig88 As String: sig88 = ChrW$(&H808)
Const sig8 As Long = 8
Const sig8Offset As Long = -3
Const maxSigByte As Byte = 9
Const sig88ToDataOffset As Long = 6
Const headBytes6 As Long = &H16
Const headBytes5 As Long = &H15
Const headBytes6Offset As Long = -16
Const headBytes5Offset As Long = -15
Const chunkSize As Long = &H100000

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

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

lastFileUpdate = FileDateTime(vDir & "SyncEngineDatabase.db")
lastRecord = 1
lastFolderID = vbNullString
End If
Get fileNum, lastRecord, b
s = b
i = InStrB(1 - headBytes6Offset, s, sig88)
lastDataEnd = 0
Do While i > 0
If i + headBytes6Offset - 2 > lastDataEnd _
And LenB(lastFolderID) > 0 Then
On Error Resume Next
odFolders.Add VBA.Array(lastParentID, lastFolderName), _
lastFolderID
If Err.number <> 0 Then
If odFolders(lastFolderID)(1) <> lastFolderName _
Or odFolders(lastFolderID)(0) <> lastParentID Then
If heads(lastFolderID) < lastHeadByte Then
odFolders.Remove lastFolderID
heads.Remove lastFolderID
odFolders.Add VBA.Array(lastParentID, _
lastFolderName), _
lastFolderID
End If
End If
End If
heads.Add lastHeadByte, lastFolderID
On Error GoTo 0
lastFolderID = vbNullString
End If

If b(i + sig8Offset) <> sig8 Then GoTo NextSig
has5HeadBytes = True
If b(i + headBytes5Offset) = headBytes5 Then
j = i + headBytes5Offset
ElseIf b(i + headBytes6Offset) = headBytes6 Then
j = i + headBytes6Offset
has5HeadBytes = False
ElseIf b(i + headBytes5Offset) <= maxSigByte Then
j = i + headBytes5Offset
Else
GoTo NextSig
End If
headByte = b(j)

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

currDataEnd = i + bytes - 1
If currDataEnd > chunkSize Then
i = i - 1
Exit Do
End If
j = i + sig88ToDataOffset
#If Mac Then
sAnsi = MidB$(s, j, idSize(1))
GoSub DecodeANSI: folderID = sUtf16
#Else
folderID = StrConv(MidB$(s, j, idSize(1)), vbUnicode)
#End If
j = j + idSize(1)
parentID = StrConv(MidB$(s, j, idSize(2)), vbUnicode)
#If Mac Then
sAnsi = MidB$(s, j, idSize(2))
GoSub DecodeANSI: parentID = sUtf16
#Else
parentID = StrConv(MidB$(s, j, idSize(2)), vbUnicode)
#End If

If folderID Like idPattern And parentID Like idPattern Then
j = j + idSize(2) + idSize(3) + idSize(4)
folderName = MidB$(s, j, nameSize)
sUtf8 = folderName: GoSub DecodeUTF8
folderName = sUtf16
lastFolderID = Left(folderID, 32)
lastParentID = Left(parentID, 32)
lastFolderName = folderName
lastHeadByte = headByte
lastDataEnd = currDataEnd
End If
NextSig:
i = InStrB(i + 1, s, sig88)
Loop
If i = 0 Then
lastRecord = lastRecord + chunkSize + headBytes6Offset
Else
lastRecord = lastRecord + i + headBytes6Offset
End If
Loop Until lastRecord > size
CloseFile:
Close #fileNum
SkipDbFile:

fileNum = FreeFile()
Open vDir & cID & ".ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
sUtf8 = b: GoSub DecodeUTF8:
b = sUtf16
#End If
Select Case True
Case dirName Like "Business#"
Dim libNrToWebColl As Collection: Set libNrToWebColl = New Collection
mainMount = vbNullString
For Each line In Split(b, vbNewLine)
webRoot = "": locRoot = "": parts = Split(line, """")
Select Case Left$(line, InStr(1, line, " = ", 0) - 1)
Case "libraryScope"
locRoot = parts(9)
syncFind = locRoot: syncID = Split(parts(10), " ")(2)
libNr = Split(line, " ")(2)
folderType = parts(3): parts = Split(parts(8), " ")
siteID = parts(1): webID = parts(2): libID = parts(3)
If mainMount = vbNullString And folderType = "ODB" Then
mainMount = locRoot: fileName = "ClientPolicy.ini"
mainSyncID = syncID: mainSyncFind = syncFind
Else: fileName = "ClientPolicy_" & libID & siteID & ".ini"
End If
On Error Resume Next
webRoot = cliPolColl(fileName)("DavUrlNamespace")
On Error GoTo 0
If webRoot = "" Then
For Each vItem In cliPolColl
If vItem("SiteID") = siteID _
And vItem("WebID") = webID _
And vItem("IrmLibraryId") = libID Then
webRoot = vItem("DavUrlNamespace"): Exit For
End If
Next vItem
End If
If webRoot = vbNullString Then Err.Raise vbErrFileNotFound _
, methodName
libNrToWebColl.Add VBA.Array(libNr, webRoot), libNr
If Not locRoot = vbNullString Then _
locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
syncID, syncFind, dirName), Key:=locRoot
Case "libraryFolder"
libNr = Split(line, " ")(3)
locRoot = parts(1): syncFind = locRoot
syncID = Split(parts(4), " ")(1)
s = vbNullString: parentID = Left$(Split(line, " ")(4), 32)
Do
On Error Resume Next: odFolders parentID
keyExists = (Err.number = 0): On Error GoTo 0
If Not keyExists Then Exit Do
s = odFolders(parentID)(1) & "/" & s
parentID = odFolders(parentID)(0)
Loop
webRoot = libNrToWebColl(libNr)(1) & s
locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
syncID, syncFind, dirName), locRoot
Case "AddedScope"
relPath = parts(5): If relPath = " " Then relPath = ""
parts = Split(parts(4), " "): siteID = parts(1)
webID = parts(2): libID = parts(3): lnkID = parts(4)
fileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini"
On Error Resume Next
webRoot = cliPolColl(fileName)("DavUrlNamespace") & relPath
On Error GoTo 0
If webRoot = "" Then
For Each vItem In cliPolColl
If vItem("SiteID") = siteID _
And vItem("WebID") = webID _
And vItem("IrmLibraryId") = libID Then
webRoot = vItem("DavUrlNamespace") & relPath
Exit For
End If
Next vItem
End If
If webRoot = vbNullString Then Err.Raise vbErrFileNotFound _
, methodName
s = vbNullString: parentID = Left$(Split(line, " ")(3), 32)
Do
On Error Resume Next: odFolders parentID
keyExists = (Err.number = 0): On Error GoTo 0
If Not keyExists Then Exit Do
s = odFolders(parentID)(1) & ps & s
parentID = odFolders(parentID)(0)
Loop
locRoot = mainMount & ps & s
locToWebColl.Add VBA.Array(locRoot, webRoot, email, _
mainSyncID, mainSyncFind, dirName), locRoot
Case Else: Exit For
End Select
Next line
Case dirName = "Personal"
For Each line In Split(b, vbNewLine)
If line Like "library = *" Then
parts = Split(line, """"): locRoot = parts(3)
syncFind = locRoot: syncID = Split(parts(4), " ")(2)
Exit For
End If
Next line
On Error Resume Next
webRoot = cliPolColl("ClientPolicy.ini")("DavUrlNamespace")
On Error GoTo 0
If locRoot = "" Or webRoot = "" Or cID = "" Then GoTo NextFolder
locToWebColl.Add VBA.Array(locRoot, webRoot & "/" & cID, email, _
syncID, syncFind, dirName), Key:=locRoot
If Dir(vDir & "GroupFolders.ini") = "" Then GoTo NextFolder
cID = vbNullString: fileNum = FreeFile()
Open vDir & "GroupFolders.ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
sUtf8 = b: GoSub DecodeUTF8
b = sUtf16
#End If
For Each line In Split(b, vbNewLine)
If line Like "*_BaseUri = *" And cID = vbNullString Then
cID = LCase$(Mid$(line, InStrRev(line, "/", , 0) + 1, _
InStrRev(line, "!", , 0) - InStrRev(line, "/", , 0) - 1))
folderID = Left$(line, InStr(line, "_") - 1)
ElseIf cID <> vbNullString Then
locToWebColl.Add VBA.Array(locRoot & ps & odFolders( _
folderID)(1), webRoot & "/" & cID & "/" & _
Mid$(line, Len(folderID) + 9), email, _
syncID, syncFind, dirName), _
Key:=locRoot & ps & odFolders(folderID)(1)
cID = vbNullString: folderID = vbNullString
End If
Next line
End Select
NextFolder:
cID = vbNullString: s = vbNullString: email = vbNullString
Next vDir

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

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

GetWebPath = GetWebPath(path, False): Exit Function
Exit Function
DecodeUTF8:
Const raiseErrors As Boolean = False
Dim o As Long, p As Long, q As Long

Static numBytesOfCodePoints(0 To 255) As Byte
Static mask(2 To 4) As Long
Static minCp(2 To 4) As Long

If numBytesOfCodePoints(0) = 0 Then
For o = &H0& To &H7F&: numBytesOfCodePoints(o) = 1: Next o
For o = &HC2& To &HDF&: numBytesOfCodePoints(o) = 2: Next o
For o = &HE0& To &HEF&: numBytesOfCodePoints(o) = 3: Next o
For o = &HF0& To &HF4&: numBytesOfCodePoints(o) = 4: Next o
For o = 2 To 4: mask(o) = (2 ^ (7 - o) - 1): Next o
minCp(2) = &H80&: minCp(3) = &H800&: minCp(4) = &H10000
End If

Dim currByte As Byte
utf8 = sUtf8
ReDim utf16(0 To (UBound(utf8) - LBound(utf8) + 1) * 2)
p = 0

o = LBound(utf8)
Do While o <= UBound(utf8)
codepoint = utf8(o)
numBytesOfCodePoint = numBytesOfCodePoints(codepoint)

If numBytesOfCodePoint = 0 Then
If raiseErrors Then Err.Raise 5, methodName, "Invalid byte"
GoTo insertErrChar
ElseIf numBytesOfCodePoint = 1 Then
utf16(p) = codepoint
p = p + 2
ElseIf o + numBytesOfCodePoint - 1 > UBound(utf8) Then
If raiseErrors Then Err.Raise 5, methodName, _
"Incomplete UTF-8 codepoint at end of string."
GoTo insertErrChar
Else
codepoint = utf8(o) And mask(numBytesOfCodePoint)

For q = 1 To numBytesOfCodePoint - 1
currByte = utf8(o + q)

If (currByte And &HC0&) = &H80& Then
codepoint = (codepoint * &H40&) + (currByte And &H3F)
Else
If raiseErrors Then _
Err.Raise 5, methodName, "Invalid continuation byte"
GoTo insertErrChar
End If
Next q
If codepoint < minCp(numBytesOfCodePoint) Then
If raiseErrors Then Err.Raise 5, methodName, "Overlong encoding"
GoTo insertErrChar
ElseIf codepoint < &HD800& Then
utf16(p) = CByte(codepoint And &HFF&)
utf16(p + 1) = CByte(codepoint \ &H100&)
p = p + 2
ElseIf codepoint < &HE000& Then
If raiseErrors Then Err.Raise 5, methodName, _
"Invalid Unicode codepoint.(Range reserved for surrogate pairs)"
GoTo insertErrChar
ElseIf codepoint < &H10000 Then
If codepoint = &HFEFF& Then GoTo nextCp
utf16(p) = codepoint And &HFF&
utf16(p + 1) = codepoint \ &H100&
p = p + 2
ElseIf codepoint < &H110000 Then
m = codepoint - &H10000
Dim loSurrogate As Long: loSurrogate = &HDC00& Or (m And &H3FF)
Dim hiSurrogate As Long: hiSurrogate = &HD800& Or (m \ &H400&)

utf16(p) = hiSurrogate And &HFF&
utf16(p + 1) = hiSurrogate \ &H100&
utf16(p + 2) = loSurrogate And &HFF&
utf16(p + 3) = loSurrogate \ &H100&
p = p + 4
Else
If raiseErrors Then Err.Raise 5, methodName, _
"Codepoint outside of valid Unicode range"
insertErrChar:  utf16(p) = &HFD
utf16(p + 1) = &HFF
p = p + 2

If numBytesOfCodePoint = 0 Then numBytesOfCodePoint = 1
End If
End If
nextCp: o = o + numBytesOfCodePoint
Loop
sUtf16 = MidB$(utf16, 1, p)
Return

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

You can then easily convert the local path to the corresponding OneDrive URL like this:

'Requires the function GetWebPath! (https://stackoverflow.com/a/74165973/12287457)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)

Your code could look like this:

Sub QrLabelCreate()
    Dim localPath as String
    localPath = "C:Users\Name\OneDrive\MyMap\" & ID & ".pdf"
'STEP 1:
'Excel VBA put data into a word-document, and export it to pdf-file (saved to OneDrive):
        .ActiveDocument.ExportAsFixedFormat _
            OutputFileName:=localPath, _
            ExportFormat:=wdExportFormatPDF
        
'STEP 2: THE PROBLEM
'====== I am not able to create code that gives me the URL to the pdf-file. ==========

'Requires the function GetWebPath! (https://stackoverflow.com/a/74165973/12287457)
    Dim oneDriveUrl as String
    oneDriveUrl = GetWebPath(localPath)

'STEP 3:
'The URL is pasted into the spreadsheet, and  VBA creates the QR-code.
End Sub

I want to point out that this is also possible using the excellent VBA-FileTools library by @Cristian Buse, as he already pointed out in the comments! If you import his library, you can convert the path to an URL in exactly the same way as with the function I provided in this answer:

'Requires https://github.com/cristianbuse/VBA-FileTools
Dim oneDriveUrl as String
oneDriveUrl = GetRemotePath(yourLocalPath)

Answer 2

You can use the VBA "ENVIRON" command to get the "OneDrive" environment variable that contains the local root to the current user's OneDrive folders. For example:

Sub ShowOneDrivePath()
Dim OutputFilePath As String

OutputFilePath = Environ("OneDrive") & "\MyMap\MyPdfName.pdf"

Debug.Print "OneDrive file path is:" & OutputFilePath 

End Sub