我的Exel VBA将pdf文件保存到本地OneDrive“C:\Users\Name\OneDrive\FileName.pdf”。 我需要找到一些代码，为 med 提供该文件的 URL，以便可以将其输入到单元格中。 URL 用于创建 QR 码，以便任何人都可以阅读 pdf 文件。
现在，我必须在 VBA 创建二维码之前手动找到 URL 并将其粘贴到电子表格中。 我在 Office 365 中工作，但 .xlsm 文件将分发给具有不同 Excel 版本的用户。 我已经为此苦苦挣扎了一段时间，所以如果有人能提供帮助，我会很高兴。
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
这样做通常一点也不容易，但幸运的是，它与更常见的问题相关：在给定 URL 时查找本地路径。
这就是为什么我现在可以在这里提供一种解决方案。
请注意，此解决方案不会创建 OneDrive“共享”链接，要创建此类链接，您需要使用 Microsoft Graph API！ 此功能创建的链接仅适用于拥有正在同步的远程文件夹的帐户。
要使用我的解决方案，请将以下函数复制到任何标准代码模块中：
'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
然后您可以轻松地将本地路径转换为相应的 OneDrive URL，如下所示：
'Requires the function GetWebPath! (https://stackoverflow.com/a/74165973/12287457)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)
您的代码可能如下所示：
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
我想指出，使用优秀的 VBA-FileTools 也可以实现这一点 @Cristian Buse 的库，正如他在评论中指出的那样！ 如果您导入他的库，您可以将路径转换为 URL，其方式与我在这个答案中提供的函数完全相同：
'Requires https://github.com/cristianbuse/VBA-FileTools
Dim oneDriveUrl as String
oneDriveUrl = GetRemotePath(yourLocalPath)
您可以使用VBA“ENVIRON”命令获取包含当前用户OneDrive文件夹的本地根目录的“OneDrive”环境变量。 例如：
Sub ShowOneDrivePath()
Dim OutputFilePath As String
OutputFilePath = Environ("OneDrive") & "\MyMap\MyPdfName.pdf"
Debug.Print "OneDrive file path is:" & OutputFilePath
End Sub