这样做通常一点都不容易，但幸运的是它与finding the local path when given the URL 更常见的问题有关。这就是为什么我现在可以在这里提供完整的解决方案。
要使用我的解决方案，请将以下函数复制到任何标准代码模块中：
'*******************************************************************************
'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.
'This function only works on Windows.
'Author: Guido Witt-Dörring
'*******************************************************************************
Public Function GetWebPath(ByVal path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
err.Raise vbObjectError + 12342, "GetWebPath Function", _
"This function only works on windows!"
#End If
If path Like "http*" Then GetWebPath = path: Exit Function
Dim webRoot As String, locRoot As String, vKey As Variant, vItem As Variant
Static locToWebDict As Object
If Not locToWebDict Is Nothing And Not rebuildCache Then
locRoot = path
If locRoot Like "*" Then locRoot = left(locRoot, Len(locRoot) - 1)
Do Until locToWebDict.Exists(locRoot) Or InStr(locRoot, "") = 0
locRoot = left(locRoot, InStrRev(locRoot, "") - 1)
Loop
If InStr(locRoot, "") = 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, locToWebDict(locRoot)(0), _
, 1), "", "/"): Exit Function
End If
Set locToWebDict = Nothing
Set locToWebDict = CreateObject("Scripting.Dictionary")
Dim cid As String, fileNum As Long, line As Variant, parts() As String
Dim tag As String, mainMount As String, relPath As String, email As String
Dim b() As Byte, n As Long, i As Long, s As String, size As Long
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, cliPolDict 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)
Dim settPath As String, wDir As String, clpPath As String
settPath = Environ("LOCALAPPDATA") & "MicrosoftOneDrivesettings"
clpPath = Environ("LOCALAPPDATA") & "MicrosoftOfficeCLP"
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
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ""
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
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 cliPolDict = CreateObject("Scripting.Dictionary")
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: s = b
Close #fileNum: fileNum = 0
Set cliPolDict(fileName) = CreateObject("Scripting.Dictionary")
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"
cliPolDict(fileName).Add Key:=tag, item:=s
Case "SiteID"
s = Replace(LCase(s), "-", "")
If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
cliPolDict(fileName).Add Key:=tag, item:=s
Case "IrmLibraryId"
s = Replace(LCase(s), "-", "")
If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
cliPolDict(fileName).Add Key:=tag, item:=s
Case "WebID"
s = Replace(LCase(s), "-", "")
If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
cliPolDict(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 = CreateObject("Scripting.Dictionary")
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, vbNullChar) - i) / 2) * 2
If n < 0 Then n = 0
folderName = MidB$(s, i, n)
If folderID Like folderIdPattern Then
odFolders.Add folderID, VBA.Array(parentID, folderName)
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
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"
If cliPolDict.Exists(fileName) Then _
webRoot = cliPolDict(fileName)("DavUrlNamespace")
Else
fileName = "ClientPolicy_" & libID & siteID & ".ini"
If cliPolDict.Exists(fileName) Then _
webRoot = cliPolDict(fileName)("DavUrlNamespace")
End If
If webRoot = "" Then
For Each vItem In cliPolDict.Items
If vItem("SiteID") = siteID And vItem("WebID") = _
webID And vItem("IrmLibraryId") = libID Then
webRoot = vItem("DavUrlNamespace"): Exit For
End If
Next vItem
End If
locToWebDict.Add locRoot, VBA.Array(webRoot, email)
Case "libraryFolder"
webRoot = "": locRoot = Split(line, """")(1)
libID = Split(line, " ")(3)
For Each vKey In locToWebDict.Keys
If vKey = libID Then
s = "": parentID = left(Split(line, " ")(4), 32)
Do Until Not odFolders.Exists(parentID)
s = odFolders(parentID)(1) & "/" & s
parentID = odFolders(parentID)(0)
Loop
webRoot = locToWebDict(vKey)(0) & s: Exit For
End If
Next vKey
locToWebDict.Add locRoot, VBA.Array(webRoot, email)
Case "AddedScope"
webRoot = "": parts = Split(line, """")
relPath = parts(5): If relPath = " " Then relPath = ""
parts = Split(parts(4), " "): siteID = parts(1)
webID = parts(2): libID = parts(3): lnkID = parts(4)
fileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini"
If cliPolDict.Exists(fileName) Then: _
webRoot = cliPolDict(fileName)("DavUrlNamespace") _
& relPath
If webRoot = "" Then
For Each vItem In cliPolDict.Items
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 Until Not odFolders.Exists(parentID)
s = odFolders(parentID)(1) & "" & s
parentID = odFolders(parentID)(0)
Loop
locRoot = mainMount & "" & s
locToWebDict.Add locRoot, VBA.Array(webRoot, email)
Case Else
For Each vKey In locToWebDict.Keys
If vKey Like "#*" Then locToWebDict.Remove vKey
Next vKey
Exit For
End Select
Next line
Case dirName = "Personal"
If Not cliPolDict.Exists("ClientPolicy.ini") Then GoTo NextFolder
For Each line In Split(b, vbNewLine)
If line Like "library = *" Then _
locRoot = Split(line, """")(3): Exit For
Next line
webRoot = cliPolDict("ClientPolicy.ini")("DavUrlNamespace")
If locRoot = "" Or webRoot = "" Or cid = "" Then GoTo NextFolder
locToWebDict(locRoot) = VBA.Array(webRoot & "/" & cid, email)
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
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
locToWebDict.Add locRoot & "" & odFolders(folderID)(1), _
VBA.Array(webRoot & "/" & cid & "/" & _
Replace(line, folderID & "_Path = ", ""), email)
cid = "": folderID = ""
End If
Next line
End Select
NextFolder:
cid = "": s = "": email = "": Set odFolders = Nothing
Next dirName
For Each vKey In locToWebDict.Keys
locRoot = vKey: webRoot = locToWebDict(vKey)(0)
email = locToWebDict(vKey)(1)
If right(webRoot, 1) = "/" Then webRoot = left(webRoot, Len(webRoot) - 1)
If right(locRoot, 1) = "" Then
locRoot = left(locRoot, Len(locRoot) - 1)
locToWebDict.Remove vKey
End If
locToWebDict(locRoot) = VBA.Array(webRoot, email)
Next vKey
GetWebPath = GetWebPath(path, False)
End Function
然后，您可以轻松地将本地路径转换为相应的 OneDrive URL，如下所示：
'Requires the function GetWebPath! ()
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)
您的代码可能如下所示：
Sub QrLabelCreate()
Dim localPath as String
localPath = "C:UsersNameOneDriveMyMap" & 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! ()
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(localPath)
'STEP 3:
'The URL is pasted into the spreadsheet, and VBA creates the QR-code.
End Sub
我想指出，这也可以使用 @Cristian Buse (GitHub) 提供的出色的 VBA-FileTools
库，正如他已经在 cmets 中指出的那样！如果您导入他的库，则可以将路径转换为 URL，其方式与我在此答案中提供的函数完全相同：
'Requires the library VBA-FileTools! ()
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)