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 complete solution here.

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.
'Author: Guido Witt-Dörring
'*******************************************************************************
Public Function GetWebPath(ByVal path As String, _
                    Optional ByVal rebuildCache As Boolean = False) _
                             As String
    #If Mac Then
        Const vbErrPermissionDenied As Long = 70
        Const vbErrInvalidFormatInResourceFile As Long = 325
        Const ps As String = "/"
    #Else
        Const ps As String = "\"
    #End If
    Dim webRoot As String, locRoot As String, vKey As Variant, vItem As Variant
    Dim s As String, keyExists As Boolean
    Static locToWebColl As Object
    Dim resColl As Object: Set resColl = New Collection

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

    If Not locToWebColl Is Nothing And Not rebuildCache Then
        locRoot = path
        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 -1: 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 Err.Raise vbObjectError + 12343, _
            "GetWebPath Function", "OneDrive URL for the path """ & path & _
            """ couldn't be found. Make sure this path points to a currently" _
            & " synchronized OneDrive or SharePoint directory on your computer!"

        GetWebPath = Replace(Replace(path, locRoot, locToWebColl(locRoot)(0), _
                     , 1), ps, "/"): Exit Function
    End If

    Set locToWebColl = Nothing
    Set locToWebColl = New Collection

    Dim cid As String, fileNum As Long, line As Variant, parts() As String
    Dim tag As String, mainMount As String, relPath As String
    Dim b() As Byte, n As Long, i As Long, size As Long, email As String
    Dim parentID As String, folderID As String, folderName As String
    Dim folderIdPattern As String, FileName As String, folderType As String
    Dim siteID As String, libID As String, webID As String, lnkID As String
    Dim odFolders As Object, cliPolColl As Object
    Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
    Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
    Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
    #If Mac Then
        Dim utf16() As Byte, utf32() As Byte, j As Long, k As Long, m As Long
        Dim charCode As Long, surrogate1 As Long, surrogate2 As Long
        ReDim b(0 To 3): b(0) = &HAB&: b(1) = &HAB&: b(2) = &HAB&: b(3) = &HAB&
        Dim sig3 As String: sig3 = b: sig3 = vbNullChar & vbNullChar & sig3
    #Else
        ReDim b(0 To 1): b(0) = &HAB&: b(1) = &HAB&
        Dim sig3 As String: sig3 = b: sig3 = vbNullChar & sig3
    #End If

    Dim settPath As String, wDir As String, clpPath As String
    #If Mac Then
        s = Environ("HOME")
        settPath = Left(s, InStrRev(s, "/Library/Containers")) & _
                   "Library/Containers/com.microsoft.OneDrive-mac/Data/" & _
                   "Library/Application Support/OneDrive/settings/"
        clpPath = s & "/Library/Application Support/Microsoft/Office/CLP/"
    #Else
        settPath = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
        clpPath = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
    #End If

    #If Mac Then
        Dim possibleDirs(0 To 11) As String: possibleDirs(0) = settPath
        For i = 1 To 9: possibleDirs(i) = settPath & "Business" & i & ps: Next i
        possibleDirs(10) = settPath & "Personal" & ps: possibleDirs(11) = clpPath
        If Not GrantAccessToMultipleFiles(possibleDirs) Then _
            Err.Raise vbErrPermissionDenied
    #End If

    Dim oneDriveSettDirs As Collection: Set oneDriveSettDirs = New Collection
    Dim dirName As Variant: dirName = Dir(settPath, vbDirectory)
    Do Until dirName = ""
        If dirName = "Personal" Or dirName Like "Business#" Then _
            oneDriveSettDirs.Add dirName
        dirName = Dir(, vbDirectory)
    Loop

    #If Mac Then
        Dim cidMask As String: s = ""
        For Each dirName In oneDriveSettDirs
            wDir = settPath & dirName & ps
            cidMask = IIf(dirName = "Personal", "????????????????", _
                          "????????-????-????-????-????????????")
            If dirName = "Personal" Then s = s & wDir & "GroupFolders.ini" & "//"
            If dirName <> "Personal" And s <> "" Then s = s & "//"
            s = s & wDir & "global.ini"

            FileName = Dir(wDir, vbNormal)
            Do Until FileName = ""
                If FileName Like cidMask & ".ini" Or _
                   FileName Like cidMask & ".dat" Or _
                   FileName Like "ClientPolicy*.ini" Then _
                    s = s & "//" & wDir & FileName
                FileName = Dir
            Loop
        Next dirName
        If Not GrantAccessToMultipleFiles(Split(s, "//")) Then _
            Err.Raise vbErrPermissionDenied
    #End If

    For Each dirName In oneDriveSettDirs
        wDir = settPath & dirName & ps
        If Dir(wDir & "global.ini", vbNormal) = "" Then GoTo NextFolder
        fileNum = FreeFile()
        Open wDir & "global.ini" For Binary Access Read As #fileNum
            ReDim b(0 To LOF(fileNum)): Get fileNum, , b
        Close #fileNum: fileNum = 0
        #If Mac Then
            b = StrConv(b, vbUnicode)
        #End If
        For Each line In Split(b, vbNewLine)
            parts = Split(line, " = ")
            If parts(0) = "cid" Then: cid = parts(1): Exit For
        Next line

        If cid = "" Then GoTo NextFolder
        If (Dir(wDir & cid & ".ini") = "" Or _
            Dir(wDir & cid & ".dat") = "") Then GoTo NextFolder
        If dirName Like "Business#" Then
            folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
        ElseIf dirName = "Personal" Then
            folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
        End If

        FileName = Dir(clpPath, vbNormal)
        Do Until FileName = ""
            If InStr(1, FileName, cid) And cid <> "" Then _
                email = LCase(Left(FileName, InStr(FileName, cid) - 2)): Exit Do
            FileName = Dir
        Loop

        Set cliPolColl = New Collection
        FileName = Dir(wDir, vbNormal)
        Do Until FileName = ""
            If FileName Like "ClientPolicy*.ini" Then
                fileNum = FreeFile()
                Open wDir & FileName For Binary Access Read As #fileNum
                    ReDim b(0 To LOF(fileNum)): Get fileNum, , b
                Close #fileNum: fileNum = 0
                #If Mac Then
                    b = StrConv(b, vbUnicode)
                #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(line, " = ") - 1)
                        s = Mid(line, InStr(line, " = ") + 3)
                        Select Case tag
                        Case "DavUrlNamespace"
                            cliPolColl(FileName).Add Key:=tag, Item:=s
                        Case "SiteID"
                            s = Replace(LCase(s), "-", "")
                            If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
                            cliPolColl(FileName).Add Key:=tag, Item:=s
                        Case "IrmLibraryId"
                            s = Replace(LCase(s), "-", "")
                            If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
                            cliPolColl(FileName).Add Key:=tag, Item:=s
                        Case "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

        fileNum = FreeFile
        Open wDir & cid & ".dat" For Binary Access Read As #fileNum
            ReDim b(0 To LOF(fileNum)): Get fileNum, , b: s = b: size = LenB(s)
        Close #fileNum: fileNum = 0
        Set odFolders = New Collection
        For Each vItem In Array(16, 8)
            i = InStrB(vItem, s, sig2)
            Do While i > vItem And i < size - 168
                If MidB$(s, i - vItem, 1) = sig1 Then
                    i = i + 8: n = InStrB(i, s, vbNullByte) - i
                    If n < 0 Then n = 0
                    If n > 39 Then n = 39
                    folderID = StrConv(MidB$(s, i, n), vbUnicode)
                    i = i + 39: n = InStrB(i, s, vbNullByte) - i
                    If n < 0 Then n = 0
                    If n > 39 Then n = 39
                    parentID = StrConv(MidB$(s, i, n), vbUnicode)
                    i = i + 121
                    n = -Int(-(InStrB(i, s, sig3) - i) / 2) * 2
                    If n < 0 Then n = 0
                    #If Mac Then
                        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) = 0 And 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
                                charCode = utf32(j + 2) * &H10000 + _
                                           utf32(j + 1) * &H100& + utf32(j)
                                m = charCode - &H10000
                                surrogate1 = &HD800& + (m \ &H400&)
                                surrogate2 = &HDC00& + (m And &H3FF)
                                utf16(k) = CByte(surrogate1 And &HFF&)
                                utf16(k + 1) = CByte(surrogate1 \ &H100&)
                                utf16(k + 2) = CByte(surrogate2 And &HFF&)
                                utf16(k + 3) = CByte(surrogate2 \ &H100&)
                                k = k + 4
                            End If
                            j = j + 4
                        Loop
                        ReDim Preserve utf16(LBound(utf16) To k - 1)
                        folderName = utf16
                    #Else
                        folderName = MidB$(s, i, n)
                    #End If
                    If folderID Like folderIdPattern Then
                        odFolders.Add VBA.Array(parentID, folderName), folderID
                    End If
                End If
                i = InStrB(i + 1, s, sig2)
            Loop
            If odFolders.Count > 0 Then Exit For
        Next vItem

        fileNum = FreeFile()
        Open wDir & cid & ".ini" For Binary Access Read As #fileNum
            ReDim b(0 To LOF(fileNum)): Get fileNum, , b
        Close #fileNum: fileNum = 0
        #If Mac Then
            b = StrConv(b, vbUnicode)
        #End If
        Select Case True
        Case dirName Like "Business#"
            mainMount = ""
            For Each line In Split(b, vbNewLine)
                Select Case Left$(line, InStr(line, " = ") - 1)
                Case "libraryScope"
                    webRoot = "": parts = Split(line, """"): locRoot = parts(9)
                    If locRoot = "" Then locRoot = Split(line, " ")(2)
                    folderType = parts(3): parts = Split(parts(8), " ")
                    siteID = parts(1): webID = parts(2): libID = parts(3)
                    If mainMount = "" And folderType = "ODB" Then
                        mainMount = locRoot: FileName = "ClientPolicy.ini"
                        On Error Resume Next: cliPolColl FileName: keyExists = _
                        (Err.Number = 0): On Error GoTo -1: On Error GoTo 0
                        If keyExists Then _
                            webRoot = cliPolColl(FileName)("DavUrlNamespace")
                    Else
                        FileName = "ClientPolicy_" & libID & siteID & ".ini"
                        On Error Resume Next: cliPolColl FileName: keyExists = _
                        (Err.Number = 0): On Error GoTo -1: On Error GoTo 0
                        If keyExists Then _
                            webRoot = cliPolColl(FileName)("DavUrlNamespace")
                    End If
                    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
                    locToWebColl.Add VBA.Array(webRoot, email, locRoot), locRoot
                Case "libraryFolder"
                    webRoot = "": locRoot = Split(line, """")(1)
                    libID = Split(line, " ")(3)
                    For Each vItem In locToWebColl
                        vKey = vItem(UBound(vItem))
                        If vKey = libID Then
                            s = "": parentID = Left(Split(line, " ")(4), 32)
                            Do
                                On Error Resume Next: odFolders parentID
                                keyExists = (Err.Number = 0)
                                On Error GoTo -1: On Error GoTo 0
                                If Not keyExists Then Exit Do
                                s = odFolders(parentID)(1) & "/" & s
                                parentID = odFolders(parentID)(0)
                            Loop
                            webRoot = vItem(0) & s: Exit For
                        End If
                    Next vItem
                    locToWebColl.Add VBA.Array(webRoot, email, locRoot), locRoot
                Case "AddedScope"
                    webRoot = "": parts = Split(line, """")
                    relPath = parts(5): If relPath = " " Then relPath = ""
                    parts = Split(parts(4), " "): siteID = parts(1)
                    webID = parts(2): libID = parts(3): lnkID = parts(4)
                    FileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini"
                    On Error Resume Next: cliPolColl FileName: keyExists = _
                    (Err.Number = 0): On Error GoTo -1: On Error GoTo 0
                    If keyExists Then: _
                        webRoot = cliPolColl(FileName)("DavUrlNamespace") _
                                  & relPath
                    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
                    s = "": parentID = Left(Split(line, " ")(3), 32)
                    Do
                        On Error Resume Next: odFolders parentID: keyExists = _
                        (Err.Number = 0): On Error GoTo -1: 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(webRoot, email, locRoot), locRoot
                Case Else
                    For Each vItem In locToWebColl
                        vKey = vItem(UBound(vItem))
                        If vKey Like "#*" Then locToWebColl.Remove vKey
                    Next vItem
                    Exit For
                End Select
            Next line
        Case dirName = "Personal"
            On Error Resume Next: cliPolColl "ClientPolicy.ini": keyExists = _
            (Err.Number = 0): On Error GoTo -1: On Error GoTo 0
            If Not keyExists Then GoTo NextFolder
            For Each line In Split(b, vbNewLine)
                If line Like "library = *" Then _
                    locRoot = Split(line, """")(3): Exit For
            Next line
            webRoot = cliPolColl("ClientPolicy.ini")("DavUrlNamespace")
            If locRoot = "" Or webRoot = "" Or cid = "" Then GoTo NextFolder
            locToWebColl.Add VBA.Array(webRoot & "/" & cid, email, locRoot), _
                             locRoot
            If Dir(wDir & "GroupFolders.ini") = "" Then GoTo NextFolder
            cid = "": fileNum = FreeFile()
            Open wDir & "GroupFolders.ini" For Binary Access Read As #fileNum
                ReDim b(0 To LOF(fileNum)): Get fileNum, , b
            Close #fileNum: fileNum = 0
            #If Mac Then
                b = StrConv(b, vbUnicode)
            #End If
            For Each line In Split(b, vbNewLine)
                If InStr(line, "BaseUri = ") And cid = "" Then
                    cid = LCase(Mid(line, InStrRev(line, "/") + 1, 16))
                    folderID = Left(line, InStr(line, "_") - 1)
                ElseIf cid <> "" Then
                    locToWebColl.Add VBA.Array(webRoot & "/" & cid & "/" & _
                                     Mid(line, Len(folderID) + 9), email, _
                                     locRoot & ps & odFolders(folderID)(1)), _
                                     locRoot & ps & odFolders(folderID)(1)
                    cid = "": folderID = ""
                End If
            Next line
        End Select
NextFolder:
        cid = "": s = "": email = "": Set odFolders = Nothing
    Next dirName

    Dim tmpColl As Collection: Set tmpColl = New Collection
    For Each vItem In locToWebColl
        vKey = vItem(UBound(vItem))
        locRoot = vKey: webRoot = locToWebColl(vKey)(0)
                          email = locToWebColl(vKey)(1)
       If Right(webRoot, 1) = "/" Then webRoot = Left(webRoot, Len(webRoot) - 1)
        If Right(locRoot, 1) = ps Then locRoot = Left(locRoot, Len(locRoot) - 1)
        tmpColl.Add VBA.Array(webRoot, email, locRoot), locRoot
    Next vItem
    Set locToWebColl = tmpColl

    GetWebPath = GetWebPath(path, False)
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 ( GitHub ), 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 the library VBA-FileTools! (https://github.com/cristianbuse/VBA-FileTools)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(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