If I want to use the open Workbook object to get the fullname of an Excel file after saving it, but that file has been synchronized to OneDrive, I get a "https" address instead of a local one, which other programs cannot interpret.
How do I get the local filename of a file like this?
Example:
Save a file to "C:\Users\user\OneDrive - Company\Documents".
OneDrive does its synchronization.
Querying Workbook.FullName now shows as "https://..."
TLDR:
For the solution, skip to the section The Solutions
For the meta-analysis, skip to the section Testing and comparison of solutions
In the last few months, @Cristian Buse (GitHub) and I performed extensive research and work on the problem in question, which led to the discovery of a large number of cases no previously available solution could solve. Because of this, we started refining our own solutions.
Unfortunately, throughout development, our solutions grew very complex. Describing how exactly they work would go far beyond the scope of a single StackOverflow answer.
For those who are interested in these technicalities, here are links to the threads we used to discuss our progress: Thread 1, Thread 2. The total volume of these threads is approximately 40,000 words or 150 pages. Luckily, it is not necessary to understand any of that to harvest the fruits of our efforts.
In the end, both of us created independent solutions:
@Cristian Buse developed his solution as part of one of his excellent VBA Libraries, to be specific, the Library VBA-FileTools. It is implemented elegantly and stepping through his code is the best way of comprehending how the solution works in detail. Furthermore, his library provides a bunch of other very useful functionalities.
My own solution comes in the form of a standalone function without any dependencies. This is useful if this problem occurs in a small project where no additional functionality is required. Because implementing the desired universal functionality is complex, it is very long and convoluted for a single procedure. I do not recommend trying to comprehend the solution by reading the code of this function.
Since the creation of our solutions, we continued to work on them improving the functionality and fixing various bugs.
NOTE: Should you encounter any bugs with our solutions, please report them here or on GitHub! In that case, I recommend you use this solution in the meantime, as it is the next most accurate solution available.
Import this library: VBA-FileTools from GitHub into your project. Getting the local name of your workbook is then as easy as:
GetLocalPath(ThisWorkbook.FullName)
Note: Full Mac support was added to this solution on Apr 5, 2023.
Copy this function, either from GitHub Gist or from this answer directly, into any standard code module. The version on GitHub Gist includes more information and some comments in and on the code.
Getting the local name of your workbook now works in the same way as with Solution 1:
GetLocalPath(ThisWorkbook.FullName)
Note that this function also offers some optional parameters, but they should almost never be needed. (See Gist for more information)
Note: Partial Mac support was added to this solution on Dec 20, 2022, and full support on Mar 20, 2023.
Important: Currently, only the Gist version contains the full Mac support implementation because it doesn't fit into this StackOverflow answer!
Here is the code of the function:
'This Function will convert a OneDrive/SharePoint Url path, e.g. Url containing
'https://d.docs.live.net/; .sharepoint.com/sites; my.sharepoint.com/personal/...
'to the locally synchronized path on your current pc or mac, e.g. a path like
'C:\users\username\OneDrive\ on Windows; or /Users/username/OneDrive/ on MacOS,
'if you have the remote directory locally synchronized with the OneDrive app.
'If no local path can be found, the input value will be returned unmodified.
'Author: Guido Witt-Dörring
'Source: https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d
Public Function GetLocalPath(ByVal path As String, _
Optional ByVal rebuildCache As Boolean = False, _
Optional ByVal returnAll As Boolean = False, _
Optional ByVal preferredMountPointOwner As String = "") _
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
Const vbErrFileNotFound As Long = 53
Const vbErrOutOfMemory As Long = 7
Const vbErrKeyAlreadyExists As Long = 457
Const chunkOverlap As Long = 1000
Static locToWebColl As Collection, lastTimeNotFound As Collection
Static lastCacheUpdate As Date
Dim resColl As Object, webRoot As String, locRoot As String
Dim vItem As Variant, s As String, keyExists As Boolean
Dim pmpo As String: pmpo = LCase(preferredMountPointOwner)
If Not locToWebColl Is Nothing And Not rebuildCache Then
Set resColl = New Collection: GetLocalPath = ""
For Each vItem In locToWebColl
locRoot = vItem(0): webRoot = vItem(1)
If InStr(1, path, webRoot, vbTextCompare) = 1 Then _
resColl.Add Key:=vItem(2), _
Item:=Replace(Replace(path, webRoot, locRoot, , 1), "/", ps)
Next vItem
If resColl.Count > 0 Then
If returnAll Then
For Each vItem In resColl: s = s & "//" & vItem: Next vItem
GetLocalPath = Mid(s, 3): Exit Function
End If
On Error Resume Next: GetLocalPath = resColl(pmpo): On Error GoTo 0
If GetLocalPath <> "" Then Exit Function
GetLocalPath = resColl(1): Exit Function
End If
If Not lastTimeNotFound Is Nothing Then
On Error Resume Next: lastTimeNotFound path
keyExists = (Err.Number = 0): On Error GoTo 0
If keyExists Then
If DateAdd("s", 1, lastTimeNotFound(path)) > Now() Then _
GetLocalPath = path: Exit Function
End If
End If
GetLocalPath = path
End If
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, size As Long, libNr 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, libNrToWebColl 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 buffSize As Long, lastChunkEndPos As Long, lenDatFile As Long
Dim lastFileUpdate As Date
#If Mac Then
Dim utf16() As Byte, utf32() As Byte, j As Long, k As Long, m As Long
Dim charCode As Long, lowSurrogate As Long, highSurrogate 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
s = ""
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ps
cid = IIf(dirName = "Personal", "????????????????", _
"????????-????-????-????-????????????")
If dirName = "Personal" Then s = s & "//" & wDir & "GroupFolders.ini"
s = s & "//" & wDir & "global.ini"
fileName = Dir(wDir, vbNormal)
Do Until fileName = ""
If fileName Like cid & ".ini" Or _
fileName Like cid & ".dat" Or _
fileName Like "ClientPolicy*.ini" Then _
s = s & "//" & wDir & fileName
fileName = Dir
Loop
Next dirName
If Not GrantAccessToMultipleFiles(Split(Mid(s, 3), "//")) Then _
Err.Raise vbErrPermissionDenied
#End If
If Not locToWebColl Is Nothing And Not rebuildCache Then
s = ""
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ps
cid = IIf(dirName = "Personal", "????????????????", _
"????????-????-????-????-????????????")
If Dir(wDir & "global.ini") <> "" Then _
s = s & "//" & wDir & "global.ini"
fileName = Dir(wDir, vbNormal)
Do Until fileName = ""
If fileName Like cid & ".ini" Then s = s & "//" & _
wDir & fileName
fileName = Dir
Loop
Next dirName
For Each vItem In Split(Mid(s, 3), "//")
If FileDateTime(vItem) > lastCacheUpdate Then _
rebuildCache = True: Exit For
Next vItem
If Not rebuildCache Then
If lastTimeNotFound Is Nothing Then _
Set lastTimeNotFound = New Collection
On Error Resume Next: lastTimeNotFound.Remove path: On Error GoTo 0
lastTimeNotFound.Add Item:=Now(), Key:=path
Exit Function
End If
End If
lastCacheUpdate = Now()
Set lastTimeNotFound = Nothing
Set locToWebColl = New Collection
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)
If line Like "cid = *" Then cid = Mid(line, 7): 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 = ""
i = InStrRev(fileName, cid, , vbTextCompare)
If i > 1 And cid <> "" Then _
email = LCase(Left(fileName, i - 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", "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
buffSize = -1
Try: On Error GoTo Catch
Set odFolders = New Collection
lastChunkEndPos = 1: i = 0
lastFileUpdate = FileDateTime(wDir & cid & ".dat")
Do
If FileDateTime(wDir & cid & ".dat") > lastFileUpdate Then GoTo Try
fileNum = FreeFile
Open wDir & cid & ".dat" For Binary Access Read As #fileNum
lenDatFile = LOF(fileNum)
If buffSize = -1 Then buffSize = lenDatFile
ReDim b(0 To buffSize + chunkOverlap)
Get fileNum, lastChunkEndPos, b: s = b: size = LenB(s)
Close #fileNum: fileNum = 0
lastChunkEndPos = lastChunkEndPos + buffSize
For vItem = 16 To 8 Step -8
i = InStrB(vItem + 1, 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
highSurrogate = &HD800& + (m \ &H400&)
lowSurrogate = &HDC00& + (m And &H3FF)
utf16(k) = CByte(highSurrogate And &HFF&)
utf16(k + 1) = CByte(highSurrogate \ &H100&)
utf16(k + 2) = CByte(lowSurrogate And &HFF&)
utf16(k + 3) = CByte(lowSurrogate \ &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
Loop Until lastChunkEndPos >= lenDatFile _
Or buffSize >= lenDatFile
GoTo Continue
Catch:
If Err.Number = vbErrKeyAlreadyExists Then
odFolders.Remove folderID
Resume
End If
If Err.Number <> vbErrOutOfMemory Then Err.Raise Err
If buffSize > &HFFFFF Then buffSize = buffSize / 2: Resume Try
Err.Raise Err
Continue: On Error GoTo 0
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 = "": Set libNrToWebColl = New Collection
For Each line In Split(b, vbNewLine)
webRoot = "": locRoot = ""
Select Case Left$(line, InStr(line, " = ") - 1)
Case "libraryScope"
parts = Split(line, """"): locRoot = parts(9)
If locRoot = "" Then libNr = 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"
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 = "" Then Err.Raise vbErrFileNotFound
If locRoot = "" Then
libNrToWebColl.Add VBA.Array(libNr, webRoot), libNr
Else: locToWebColl.Add VBA.Array(locRoot, webRoot, email) _
, locRoot
End If
Case "libraryFolder"
locRoot = Split(line, """")(1): libNr = Split(line, " ")(3)
For Each vItem In libNrToWebColl
If vItem(0) = libNr Then
s = "": 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 = vItem(1) & s: Exit For
End If
Next vItem
locToWebColl.Add VBA.Array(locRoot, webRoot, email), locRoot
Case "AddedScope"
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
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 = "" Then Err.Raise vbErrFileNotFound
s = "": 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), locRoot
Case Else
Exit For
End Select
Next line
Case dirName = "Personal"
For Each line In Split(b, vbNewLine)
If line Like "library = *" Then _
locRoot = Split(line, """")(3): Exit For
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), _
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(locRoot & ps & odFolders( _
folderID)(1), webRoot & "/" & cid & "/" & _
Mid(line, Len(folderID) + 9), email), _
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
locRoot = vItem(0): webRoot = vItem(1): email = vItem(2)
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(locRoot, webRoot, email), locRoot
Next vItem
Set locToWebColl = tmpColl
GetLocalPath = GetLocalPath(path, False, returnAll, pmpo): Exit Function
End Function
Both solutions get all of the required information for translating the UrlPath/WebPath to a LocalPath from the OneDrive settings files inside of the directory %localappdata%\Microsoft\OneDrive\settings\....
This means, contrary to most other solutions online, the registry is not used! The reasons for this are explained in the Gist repository of Solution 2.
The following files will be read:
(Wildcards: * - zero or more characters; ? - one character)
????????????????.dat
????????????????.ini
global.ini
GroupFolders.ini
????????-????-????-????-????????????.dat
????????-????-????-????-????????????.ini
ClientPolicy*.ini
All of the .ini files can be read easily as they use UTF-16 encoding.
The .dat files are much more difficult to decipher, because they use a proprietary binary format. Luckily, the information we need can be extracted by looking for certain byte-patterns inside these files and copying and converting the data at a certain offset from these "signature" bytes.
Data from all of these files is used, to create a "dictionary" of all the local mount points on your pc, and their corresponding WebPath. For example, for your personal OneDrive, such a local mount point could look like this:
C:\Users\Username\OneDrive, and the corresponding WebPath could look like this: https://d.docs.live.net/f9d8c1184686d493.
This "dictionary" can then be used to "translate" a given WebPath to a local path by replacing the part that is equal to one of the elements of the dictionary with the corresponding local mount point. For example, this WebPath: https://d.docs.live.net/f9d8c1184686d493/Folder/File.xlsm will be correctly "translated" to C:\Users\Username\OneDrive\Folder\File.xlsm
Because all possible WebPaths for the local machine can be translated by the same dictionary, it is implemented as Static in both solutions. This means it will only be written the first time the function is called, all subsequent function calls will find the "dictionary" already initialized leading to shorter run time.
I conducted extensive testing of all solutions I could find online. A selection of these tests will be presented here.
This is a list of some of the tested solutions:
Each line in the table in the below image represents one solution in the above table and they can be correlated using the solution number.
Likewise, each column represents a test case, they can be correlated to this test-table by using the test-number. Unfortunately Stack Overflow doesn't allow answers long enough to include the table of test cases directly in this post.
All of this testing was done on Windows. On macOS, every solution except for Nr 32 and Nr 33 would pass 0/46 tests. The solutions presented in this post (#32 and #33) also pass every test on macOS.
Most solutions pass very few tests. Many of these tests are relatively dificult to solve, some are absolute edge cases, such as tests Nr 41 to 46, that test how a solution deals with OneDrive folders that are synced to multiple different local paths, which can only happen if multiple Business OneDrive accounts are logged in on the same PC and even then needs some special setup. (More information on that can be found here in Thread 2)
Test Nr 22 contains various Unicode emoji characters in some folder names, this is why many solutions fail with error here.
Another reason why many solutions perform poorly is that the environment variables Environ("OneDrive"), Environ("OneDriveCommercial"),Environ("OneDriveConsumer"), which many solutions build on, are not reliable, especially when you have multiple business OneDrive accounts logged in at the same time, like I do. Note that even if they always returned their expected values, it would be way to little information to solve all cases.
If you have another different solution you would like me to test, let me know and I'll add it to this section.
I found a thread online which contained enough information to put something simple together to solve this. I actually implemented the solution in Ruby, but this is the VBA version:
Option Explicit
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
Local_Workbook_Name = Replace(wb.FullName, "/", "\")
'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Trim OneDrive designators
For Ctr = 1 To 4
Local_Workbook_Name = Mid(Local_Workbook_Name, InStr(Local_Workbook_Name, "\") + 1)
Next
'Construct the name
Local_Workbook_Name = UserProfilePath & "\OneDrive\" & Local_Workbook_Name
Else
Local_Workbook_Name = wb.FullName
End If
End Function
Private Sub testy()
MsgBox ActiveWorkbook.FullName & vbCrLf & Local_Workbook_Name(ActiveWorkbook)
End Sub
Horoman's version (2020-03-30) is good because it works on both private and commercial OneDrive. However it crashed on me because the line "LocalFullName = oneDrivePath & Application.PathSeparator & endFilePath" inserts a slash between oneDrivePath & endFilePath. Moreover, one should really try out paths "OneDriveCommercial" and "OneDriveConsumer" before "OneDrive". So here's the code that works for me:
Sub TestLocalFullName()
Debug.Print "URL: " & ActiveWorkbook.FullName
Debug.Print "Local: " & LocalFullName(ActiveWorkbook.FullName)
Debug.Print "Test: " & Dir(LocalFullName(ActiveWorkbook.FullName))
End Sub
Private Function LocalFullName$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive
'Reference https://stackoverflow.com/questions/33734706/excels-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02
Dim ii&
Dim iPos&
Dim oneDrivePath$
Dim endFilePath$
If Left(fullPath, 8) = "https://" Then 'Possibly a OneDrive URL
If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then 'Commercial OneDrive
'For commercial OneDrive, path looks like "https://companyName-my.sharepoint.com/personal/userName_domain_com/Documents" & file.FullName)
'Find "/Documents" in string and replace everything before the end with OneDrive local path
iPos = InStr(1, fullPath, "/Documents") + Len("/Documents") 'find "/Documents" position in file URL
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without pointer in OneDrive. Include leading "/"
Else 'Personal OneDrive
'For personal OneDrive, path looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName
'We can get local file path by replacing "https.." up to the 4th slash, with the OneDrive local path obtained from registry
iPos = 8 'Last slash in https://
For ii = 1 To 2
iPos = InStr(iPos + 1, fullPath, "/") 'find 4th slash
Next ii
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without OneDrive root. Include leading "/"
End If
endFilePath = Replace(endFilePath, "/", Application.PathSeparator) 'Replace forward slashes with back slashes (URL type to Windows type)
For ii = 1 To 3 'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive")) 'Check possible local paths. "OneDrive" should be the last one
If 0 < Len(oneDrivePath) Then
LocalFullName = oneDrivePath & endFilePath
Exit Function 'Success (i.e. found the correct Environ parameter)
End If
Next ii
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
LocalFullName = vbNullString
Else
LocalFullName = fullPath
End If
End Function
I have adjusted the function provided by others to account for some additional constraints:
When you share files via a team site, it's not "my.sharepoint.com/" but "sharepoint.com/" that you should use to determine if it's a commercial version.
It is better to count the slashes rather than using the position of "/Documents" because, for example in French, the document folder is called "Documents partages". It is preferable to count 4 slashes for commercial use and 2 slashes for personal use.
If the SharePoint folder added as a shortcut to OneDrive is not at the root, the local address on the hard drive does not contain parent folders on the SharePoint.
Here is the code that takes my changes into account:
Public Function AdresseLocal$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive
'Reference https://stackoverflow.com/questions/33734706/excels-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02
Dim ii&
Dim iPos&
Dim oneDrivePath$
Dim endFilePath$
Dim NbSlash
If Left(fullPath, 8) = "https://" Then
If InStr(1, fullPath, "sharepoint.com/") <> 0 Then 'Commercial OneDrive
NbSlash = 4
Else 'Personal OneDrive
NbSlash = 2
End If
iPos = 8 'Last slash in https://
For ii = 1 To NbSlash
iPos = InStr(iPos + 1, fullPath, "/")
Next ii
endFilePath = Mid(fullPath, iPos)
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
For ii = 1 To 3
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive"))
If 0 < Len(oneDrivePath) Then Exit For
Next ii
AdresseLocal = oneDrivePath & endFilePath
While Len(Dir(AdresseLocal, vbDirectory)) = 0 And InStr(2, endFilePath, Application.PathSeparator) > 0
endFilePath = Mid(endFilePath, InStr(2, endFilePath, Application.PathSeparator))
AdresseLocal = oneDrivePath & endFilePath
Wend
Else
AdresseLocal = fullPath
End If
End Function
...which builds on the work of the different contributors.
It's possible to improve on Virtuoso's answer to reduce (though not eliminate) the chance that the function returns a "wrong" file location. The problem is that there are various URLs that a workbook's .FullName can be. These are three I'm aware of:
On my PC I can get the relevant local folders to map the first two URLs via the OneDriveConsumer and OneDriveCommercial environment variables, that exist in addition to the OneDrive environment variable, so the code below makes use of these. I'm not aware that it's possible to handle the "Shared with Me" files and the code below will return their https://-style location.
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
Dim i As Long, j As Long
Dim OneDrivePath As String
Dim ShortName As String
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For i = 1 To 4
ShortName = Mid(ShortName, InStr(ShortName, "\") + 1)
Next
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
For j = 1 To 3
OneDrivePath = Environ(Choose(j, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
Local_Workbook_Name = OneDrivePath & "\" & ShortName
If Dir(Local_Workbook_Name) <> "" Then
Exit Function
End If
End If
Next j
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
End If
Local_Workbook_Name = wb.FullName
End Function
Unfortunately, if files exist with identical paths within both the OneDrive folder and the OneDrive for Business folder, then the code can't distinguish between them, and may return the "wrong one". I don't have a solution for that.
Easy Fix (early 2019) - For anyone else having this issue:
OneDrive > Settings > Office: - Uncheck 'Use Office applications to sync Office files that I open'
This lets excel save the file in the typical "C:\Users[UserName]\OneDrive..." file format instead of the UNC "https:\" format.
I like the Version from TWMIC with the use of the Registry. All other Version did not work at my oneDrive for Business. There are some folders where the name is slightly different to the URL, for example in the URL are partly no spaces but in the folder there are. If it is from Teams and in the Team Name are spaces then this is a problem. Even the Folder Names from Teams are different than the URL, depending which folder level in Teams you are syncing.
The Version from TWMIC is tagged as dangerous at my work computer and i can't use it, very sad about that. So i made a Version which reads the ini File from oneDrive for Busines, if it is OneDrive for Business...
Public Function AdresseLocal$(ByVal fullPath$)
'Finds local path for a OneDrive file URL, using environment variables of OneDrive and loading the settings ini File of OneDrive
'Reference https://stackoverflow.com/questions/33734706/excels-fullname-property-with-onedrive
'Authors: Philip Swannell 2019-01-14, MatChrupczalski 2019-05-19, Horoman 2020-03-29, P.G.Schild 2020-04-02, Iksi 2021-08-28
Dim ScreenUpdate As Boolean
Dim ii&
Dim iPos&
Dim DatFile$, SettingsDir$, Temp$
Dim oneDrivePath$, oneDriveURL$
Dim endFilePath$
If Left(fullPath, 8) = "https://" Then
If InStr(1, fullPath, "sharepoint.com") <> 0 Then 'Commercial OneDrive
'Find the correct settings File, I'm not sure if it is always in Folder Business1, so trying to find a Folder Business and then Business1, 2 ....
'First find *.dat File, seems to be only one of that type, the correct ini File is the same Name than the dat File
DatFile = Dir(Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business\*.dat")
If DatFile <> "" Then SettingsDir = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business\"
For ii = 1 To 9
Temp = Dir(Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business" & ii & "\*.dat")
If Temp <> "" Then
If SettingsDir = "" Then
DatFile = Temp
SettingsDir = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\Business" & ii & "\"
Else
MsgBox "There is more than one OneDrive settings Folder!"
End If
End If
Next
'Open ini File without showing
ScreenUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Workbooks.OpenText Filename:= _
SettingsDir & Left(DatFile, Len(DatFile) - 3) & "ini" _
, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:= _
False, Comma:=False, Space:=True, Other:=False, TrailingMinusNumbers:=True
ii = 1
Do While Cells(ii, 1) = "libraryScope"
'Search the correct URL which fits to the fullPath and then search the corresponding Folder
If InStr(fullPath, Cells(ii, 9)) = 1 Then
oneDriveURL = Cells(ii, 9)
If Cells(ii, 15) <> "" Then
oneDrivePath = Cells(ii, 15)
Else
iPos = Cells(ii, 3)
Do Until Cells(ii, 1) = "libraryFolder"
ii = ii + 1
Loop
Do While Cells(ii, 1) = "libraryFolder"
If Cells(ii, 4) = iPos Then
oneDrivePath = Cells(ii, 7)
Exit Do
End If
ii = ii + 1
Loop
End If
Exit Do
End If
ii = ii + 1
Loop
ActiveWorkbook.Close False
Application.ScreenUpdating = ScreenUpdate
endFilePath = Mid(fullPath, Len(oneDriveURL) + 1)
Else 'Personal OneDrive
'For personal OneDrive, path looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName
'We can get local file path by replacing "https.." up to the 4th slash, with the OneDrive local path obtained from registry
iPos = 8 'Last slash in https://
For ii = 1 To 2
iPos = InStr(iPos + 1, fullPath, "/") 'find 4th slash
Next ii
endFilePath = Mid(fullPath, iPos) 'Get the ending file path without OneDrive root. Include leading "/"
End If
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
If Len(oneDrivePath) <= 0 Then
For ii = 1 To 3 'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive")) 'Check possible local paths. "OneDrive" should be the last one
Next ii
End If
AdresseLocal = oneDrivePath & endFilePath
While Len(Dir(AdresseLocal, vbDirectory)) = 0 And InStr(2, endFilePath, Application.PathSeparator) > 0
endFilePath = Mid(endFilePath, InStr(2, endFilePath, Application.PathSeparator))
AdresseLocal = oneDrivePath & endFilePath
Wend
Else
AdresseLocal = fullPath
End If
End Function
For me this works great!
The solution presented in the following does not work in absolutely all cases, but it probably works in more than 99% of real-world scenarios. If you are looking for a solution that covers even the edge cases, please look at this universal solution.
An advantage of this solution compared to the above linked universal solution is its simplicity and therefore its lower likelihood to break because of OneDrive/Windows updates.
The function to convert the "WebPath" to a local path looks like this:
Public Function GetLocalPath(ByVal Path As String) As String
Const HKCU = &H80000001
Dim objReg As Object, rPath As String, subKeys(), subKey
Dim urlNamespace As String, mountPoint As String, secPart As String
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\." & _
"\root\default:StdRegProv")
rPath = "Software\SyncEngines\Providers\OneDrive\"
objReg.EnumKey HKCU, rPath, subKeys
For Each subKey In subKeys
objReg.GetStringValue HKCU, rPath & subKey, "UrlNamespace", urlNamespace
If InStr(Path, urlNamespace) > 0 Then
objReg.GetStringValue HKCU, rPath & subKey, "MountPoint", mountPoint
secPart = Replace(Mid(Path, Len(urlNamespace)), "/", "\")
Path = mountPoint & secPart
Do Until Dir(Path, vbDirectory) <> "" Or InStr(2, secPart, "\") = 0
secPart = Mid(secPart, InStr(2, secPart, "\"))
Path = mountPoint & secPart
Loop
Exit For
End If
Next
GetLocalPath = Path
End Function
To now get the local full name of your workbook, just use GetLocalPath(ThisWorkbook.FullName)
Very helpful, thanks. I had a similar issue, but with a folder name rather than a filename. Consequently I modified it slightly. I made it work for folder names AND filenames (doesn't have to be a workbook). In case it's helpful, code is below:
Public Function Local_Name(theName As String) As String
Dim i As Integer
Dim objShell As Object
Dim UserProfilePath As String
' Check if it looks like a OneDrive location.
If InStr(1, theName, "https://", vbTextCompare) > 0 Then
' Replace forward slashes with back slashes.
Local_Name = Replace(theName, "/", "\")
'Get environment path using vbscript.
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
' Trim OneDrive designators.
For i = 1 To 4
Local_Name = Mid(Local_Name, InStr(Local_Name, "\") + 1)
Next i
' Construct the name.
Local_Name = UserProfilePath & "\OneDrive\" & Local_Name
Else
' (must already be local).
Local_Name = theName
End If
End Function
This is really great stuff. I have run into this problem on some windows 10 machines but not others and it seems to come and go. I tried everything resetting OneDrive, changing the configuration etc. The only thing I tried that at least works on my machine is to use Fullname=CurDir & FileName, instead of FullName= activeworkbook.Path & FileName.
This returned the full local name without the https stuff and I was able to open my file ok.
Instead of using the variable ThisWorkbook.Path use Environ("OneDrive").
Option Explicit
'
Function TransferURL(wbkURL As String) As String
' Converts the URL of a OneDrive into a path.
' Returns the path's name.
Dim oFs As Object
Dim oFl As Object
Dim oSubFl As Object
Dim pos As Integer
Dim pathPart As String
Dim oneDrive As String
Dim subFl As String
Set oFs = CreateObject("Scripting.FileSystemObject")
' Check the version of OneDrive.
If VBA.InStr(1, _
VBA.UCase(wbkURL), "MY.SHAREPOINT.COM") = 0 Then
oneDrive = "OneDriveConsumer"
Else
oneDrive = "OneDriveCommercial"
End If
Set oFl = oFs.GetFolder(Environ(oneDrive))
' Iteration over OneDrive's subfolders.
For Each oSubFl In oFl.SUBFOLDERS
subFl = "/" & VBA.Mid(oSubFl.Path, _
VBA.Len(Environ(oneDrive)) + 2) & "/"
' Check if part of the URL.
If VBA.InStr(1, _
wbkURL, subFl) > 0 Then
' Determine the path after OneDrive's folder.
pos = VBA.InStr(1, _
wbkURL, subFl)
pathPart = VBA.Mid(VBA.Replace(wbkURL, "/", _
Application.PathSeparator), pos)
End If
Next
TransferURL = Environ(oneDrive) & pathPart
End Function
Call the function by:
' Check if path specification as URL.
If VBA.Left(VBA.UCase(oWbk.Path), _
5) = "HTTPS" Then
' Call ...
pathName = TransferURL(oWbk.Path)
End If
The differentiation between OneDriveConsumer and OneDriveCommercial is derived from:
Edited by MatChrupczalski Thursday, May 9, 2019 5:45 PM
I have the same problem as you. But I have solved that problem. The first I turn off OneDrive before I running the script.
you can add this script on the first script into your vba/module:
Call Shell("cmd.exe /S /C" & "%LOCALAPPDATA%\Microsoft\OneDrive\OneDrive.exe /shutdown")
and then, on your last script on your vba/module you can insert this for activate your OneDrive:
Call Shell("cmd.exe /S /C" & "start %LOCALAPPDATA%\Microsoft\OneDrive\OneDrive.exe /background")
I am using Windows10 on that script.
Option Explicit
Private coll_Locations As Collection ' using Collection but could just as easily use Dictionary
Public Const HKEY_CURRENT_USER = &H80000001
'
Public Function getOneDrv_PathFor(ByVal sPath As String, Optional ByVal sType As String = "") As String
' convert start of passed in path from URL to Local or vice.versa, (for OneDrive Sync'd folders)
' sType : if starts L(ocal) return local path, if starts U(rl) then return URL Path, else return other mode to that passed in
Dim sPathNature As String
Dim vKey As Variant
Dim Slash As String, Slash2 As String
getOneDrv_PathFor = sPath ' return unchanged if no action required or recognised
sType = UCase(Left(sType, 1))
If sType <> "L" And sType <> "U" Then sType = ""
sPathNature = IIf(Left(sPath, 4) = "http", "U", "L")
If sType <> "" And sType = sPathNature Then Exit Function ' nothing to do
If coll_Locations Is Nothing Then get_Locations
For Each vKey In coll_Locations
If InStr(1, sPath, vKey, vbTextCompare) = 1 Then
Slash = IIf(sPathNature = "U", "/", "\")
Slash2 = IIf(Slash = "/", "\", "/")
getOneDrv_PathFor = coll_Locations(vKey) & Replace(Mid(sPath, Len(vKey) + 1), Slash, Slash2)
Exit For
End If
Next
End Function
Private Sub get_Locations()
' collect possible OneDrive: URL vs Local paths
Dim oWMI As Object
Dim sRegPath As String, arrSubKeys() As Variant, vSubKey As Variant
Dim sServiceEndPointUri As String, sUserFolder As String
Set coll_Locations = New Collection
Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
sRegPath = "Software\Microsoft\OneDrive\Accounts\"
oWMI.EnumKey HKEY_CURRENT_USER, sRegPath, arrSubKeys
For Each vSubKey In arrSubKeys
oWMI.GetStringValue HKEY_CURRENT_USER, sRegPath & vSubKey, "ServiceEndPointUri", sServiceEndPointUri
oWMI.GetStringValue HKEY_CURRENT_USER, sRegPath & vSubKey, "UserFolder", sUserFolder
If sServiceEndPointUri <> "" And sUserFolder <> "" Then
If Right(sServiceEndPointUri, 5) = "/_api" Then sServiceEndPointUri = Left(sServiceEndPointUri, Len(sServiceEndPointUri) - 4) & "Documents/"
sUserFolder = sUserFolder & "\"
coll_Locations.Add Item:=sServiceEndPointUri, Key:=sUserFolder
coll_Locations.Add Item:=sUserFolder, Key:=sServiceEndPointUri
End If
Next
'listOneDrv_Locations
Set oWMI = Nothing
End Sub
Public Sub listOneDrv_Locations()
' to list what's in the collection
Dim vKey As Variant
' Set coll_Locations = Nothing
If coll_Locations Is Nothing Then get_Locations
For Each vKey In coll_Locations
Debug.Print vKey, coll_Locations(vKey)
Next
End Sub
Then to get the LocalPath would be strLocalPath = getOneDrv_PathFor(strCurrentPath, "Local")
I know the question was tagged with VBA, but I found this while I was trying to solve with C#. I wrote a version similar to @TWMIC answer as the following:
string LocalPath( string fullPath )
{
if ( fullPath.StartsWith( "https://", StringComparison.InvariantCultureIgnoreCase ) )
{
// So Documents/ location works below
fullPath = fullPath.Replace( "\\", "/" );
var userAccounts = Microsoft.Win32.Registry.CurrentUser
.OpenSubKey(@"Software\Microsoft\OneDrive\Accounts\");
if (userAccounts != null)
{
foreach (var accountName in userAccounts.GetSubKeyNames())
{
var account = userAccounts.OpenSubKey(accountName);
var endPoint = account.GetValue("ServiceEndPointUri") as string;
var userFolder = account.GetValue("UserFolder") as string;
if (!string.IsNullOrEmpty(endPoint) && !string.IsNullOrEmpty(userFolder))
{
if (endPoint.EndsWith("/_api"))
{
endPoint = endPoint.Substring(0, endPoint.Length - 4) + "documents/";
}
if (fullPath.StartsWith(endPoint, StringComparison.InvariantCultureIgnoreCase))
{
return Path.Combine(userFolder, fullPath.Substring(endPoint.Length));
}
}
}
}
}
return fullPath;
}
I have recently found a new unique solution to this problem and because it is currently not described anywhere online I'd like to point it out here.
Microsoft recently added a new button to the Excel UI for OneDrive synchronized workbooks.
Clicking it copies the local path to the clipboard. This is the first official Microsoft solution for this problem I know of.
Unfortunately, this functionality is not (yet?) part of the object model, hence, to get this info in VBA, the button must be clicked by the code. This is possible but isn't 100% reliable. An example of how to do this looks like this:
Public Function GetLocalPathOfWorkbook(Optional ByVal wb As Workbook = Nothing) _
As String
If wb Is Nothing Then Set wb = ThisWorkbook
GetLocalPathOfWorkbook = wb.FullName
If Not wb.FullName Like "http*" Or wb.FullName = "" Then Exit Function
With Application
Dim appScreenUpdating As Boolean: appScreenUpdating = .ScreenUpdating
Dim appEnableEvents As Boolean: appEnableEvents = .EnableEvents
Dim appDisplayAlerts As Boolean: appDisplayAlerts = .DisplayAlerts
.ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False
End With
With wb.Windows(1)
Dim wbVisible As Boolean: wbVisible = .Visible
Dim wbWindowState As XlWindowState: wbWindowState = .WindowState
If Not .Visible Then .Visible = True
If .WindowState = xlMinimized Then .WindowState = xlNormal
.Activate
End With
On Error GoTo RestoreAppState
SendKeys "%f", True 'Weirdly, both, the SendKeys and the CommandBars.Execute
SendKeys "%i", True 'are necessary for the code to run reliably, even though
'they (should) just do the same thing twice in theory?
Application.CommandBars.ExecuteMso "FileProperties"
SendKeys "%l", True
SendKeys "{ESC}", True
DoEvents
GetLocalPathOfWorkbook = _
CreateObject("HtmlFile").parentWindow.clipboardData.GetData("text")
RestoreAppState:
wb.Windows(1).WindowState = wbWindowState
wb.Windows(1).Visible = wbVisible
Application.ScreenUpdating = appScreenUpdating
Application.EnableEvents = appEnableEvents
Application.DisplayAlerts = appDisplayAlerts
If Err.Number <> 0 Then Err.Raise Err
End Function
Unfortunately, this code sometimes randomly stops at the DoEvents line with the message "Code execution was interrupted.". This is very annoying, especially because clicking Debug and then Continue will let the code finish without further issues.
Since this solution uses SendKeys and UI automation it can also cause other random unforeseen problems or fail if the user interacts with the app while the code is running. Sometimes, issues even occur without external user interaction.
Apart from these drawbacks, this method is actually pretty powerful and can even be used to get the local path of any OneDrive/SharePoint "web path". (A "web path" is a link that's not a "share link")
This is possible because the Workbook.SaveAs method supports OneDrive URLs. Therefore, to find the local path, we can use code to create a temporary workbook in a location, open it, use the above-defined function, close it, and delete it again.
In the following, I've implemented a proof of concept to show that this works for arbitrary paths (Only if they exist!):
Public Function GetLocalPath(ByVal path As String)
GetLocalPath = path
If Not path Like "http*" Or path = "" Then Exit Function
Dim testWbName As String: testWbName = RandomStringAlphanumeric(6)
Dim wb As Workbook: Set wb = Application.Workbooks.Add
'Find out if path is a file or folder
Dim isFile As Boolean
If Not Right(path, 1) = "/" Then
On Error Resume Next
wb.SaveAs path & "/" & testWbName
If Err.Number = 1004 Then
On Error GoTo 0
wb.Saved = True 'The file that failed saving must be closed because
wb.Close SaveChanges:=xlDoNotSaveChanges 'next save attempt fails
Set wb = Nothing
isFile = True
End If
End If
If wb Is Nothing Then Set wb = Application.Workbooks.Add
'Save the test file if not already saved
On Error GoTo SaveFailed
If isFile Then
wb.SaveAs Left(path, InStrRev(path, "/")) & testWbName
ElseIf Right(path, 1) = "/" Then
wb.SaveAs path & testWbName
End If
On Error GoTo 0
'Get local path, close and delete file
Dim localTempFileFullName As String, localTempFilePath As String
localTempFileFullName = GetLocalPathOfWorkbook(wb)
localTempFilePath = Left(localTempFileFullName, InStrRev(localTempFileFullName, "\"))
wb.Saved = True
wb.Close SaveChanges:=xlDoNotSaveChanges
On Error GoTo DeleteFailed
CreateObject("Scripting.FileSystemObject").DeleteFile localTempFileFullName
On Error GoTo 0
If isFile Then
GetLocalPath = localTempFilePath & Mid(path, InStrRev(path, "/") + 1)
Else
If Right(path, 1) = "/" Then
GetLocalPath = localTempFilePath
Else
GetLocalPath = Left(localTempFilePath, Len(localTempFilePath) - 1)
End If
End If
Exit Function
SaveFailed:
If Err.Number = 1004 Then
On Error GoTo 0
wb.Saved = True
wb.Close SaveChanges:=xlDoNotSaveChanges
Exit Function
End If
Err.Raise Err
Exit Function
DeleteFailed:
MsgBox "GetLocalPath failed to get the local path of '" & path & "'" & _
vbNewLine & "A temporary file named " & testWbName & ".xlsx was " & _
"created in the location '" & path & "', please delete it manually." _
, vbCritical
Err.Raise Err.Number, "GetLocalPath", _
"Failed to delete this file: " & path & testWbName
End Function
Private Function RandomStringAlphanumeric(ByVal Length As Long) As String
Dim b() As Byte, i As Long, char As Long: Randomize
If Length < 1 Then Exit Function
ReDim b(0 To Length * 2 - 1)
For i = 0 To Length - 1
Select Case Rnd
Case Is < 0.41935: Do: char = 25 * Rnd + 65: Loop Until char <> 0
Case Is < 0.83871: Do: char = 25 * Rnd + 97: Loop Until char <> 0
Case Else: Do: char = 9 * Rnd + 48: Loop Until char <> 0
End Select
b(2 * i) = (Int(char)) And 255
Next i
RandomStringAlphanumeric = b
End Function
Even though this method seems alluring as it is using an 'official' way of obtaining the local path without hacking around in the registry/settings files, it is, as of now, much less reliable than the universal solution, which is currently marked as the accepted answer in this thread.
The main problems are, that it is very slow and error-prone, due to a large amount of UI automation involved in my attempted solution. Also, it doesn't work on Mac, as the backstage view is not available there.
Currently, I would much prefer the universal (currently accepted) solution in every possible scenario, its advantages are numerous:
GetLocalPathOfWorkbook works like that too, GetLocalPath does not.Workbook.SaveAs as used in this post must save the file directly to OneDrive.Workbook.SaveAs fails, for example for paths with many more obscure Unicode characters that make the URL-encoded path exceedingly long. The universal solution from the accepted answer can deal with that.To give an approximate idea of the capabilities of this method, in the testing presented here it gets between 30 and 40 of 46 tests right and takes around 500 seconds. Importantly though, it can not complete a test run without user interaction because of the many randomly occurring errors. Also, there are some tests, that currently always fail.
In light of all the drawbacks of this method, even this short solution is, by far, preferable.
If a more reliable way of clicking that button is found, without using SendKeys and physically navigating to the file info section, it could potentially be very useful in the future, especially on already open workbooks.
If anyone has some ideas on how to potentially do that, please let me know!
I guess there is a little bug in the code of JK2017: The"ShortName"-variable has to be rebuilt at every start of these 3 versions of OneDrive. So ist has to be inside the 'For i = 1 To 3' loop. I have also added the choise to get only the path instead of the full filename.
Private Function Local_Workbook_Name(ByRef wb As Workbook, Optional bPathOnly As Boolean = False) As String
'returns local wb path or nothing if local path not found
Dim i As Long, x As Long
Dim OneDrivePath As String
Dim ShortName As String
Dim testWbkPath As String
Dim OneDrivePathFound As Boolean
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'loop through three OneDrive options
For i = 1 To 3
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For x = 1 To 4
ShortName = RemoveTopFolderFromPath(ShortName)
Next
'Choose the version of Onedrive
OneDrivePath = Environ(Choose(i, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
Do While ShortName Like "*\*"
testWbkPath = OneDrivePath & "\" & ShortName
If Not (Dir(testWbkPath)) = vbNullString Then
OneDrivePathFound = True
Exit Do
End If
'remove top folder in path
ShortName = RemoveTopFolderFromPath(ShortName)
Loop
End If
If OneDrivePathFound Then Exit For
Next i
Else
If bPathOnly Then
Local_Workbook_Name = RemoveFileNameFromPath(wb.FullName)
Else
Local_Workbook_Name = wb.FullName
End If
End If
If OneDrivePathFound Then
If bPathOnly Then
Local_Workbook_Name = RemoveFileNameFromPath(testWbkPath)
Else
Local_Workbook_Name = testWbkPath
End If
End If
End Function
Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid(ShortName, InStr(ShortName, "\") + 1)
End Function
Function RemoveFileNameFromPath(ByVal ShortName As String) As String
RemoveFileNameFromPath = Mid(ShortName, 1, Len(ShortName) - InStr(StrReverse(ShortName), "\"))
End Function
The different number of slashes "/" could be related with different versions of OneDrive (private/professional). Compare MatChrupczalski post on the msdn website: https://social.msdn.microsoft.com/Forums/en-US/1331519b-1dd1-4aa0-8f4f-0453e1647f57/how-to-get-physical-path-instead-of-url-onedrive?forum=officegeneral
Therefore I adapted the function to the following:
Sub TestMySolution()
MsgBox ActiveWorkbook.FullName & vbCrLf & LocalFullName(ActiveWorkbook.FullName)
End Sub
' 29.03.2020 Horoman
' main parts by Philip Swannell 14.01.2019
' combined with parts from MatChrupczalski 19.05.2019
' using environment variables of OneDrive
Private Function LocalFullName(ByVal fullPath As String) As String
Dim i As Long, j As Long
Dim oneDrivePath As String
Dim endFilePath As String
Dim iDocumentsPosition As Integer
'Check if it looks like a OneDrive location
If InStr(1, fullPath, "https://", vbTextCompare) > 0 Then
'for commercial OneDrive file path seems to be like "https://companyName-my.sharepoint.com/personal/userName_domain_com/Documents" & file.FullName)
If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then
'find "/Documents" in string and replace everything before the end with OneDrive local path
iDocumentsPosition = InStr(1, fullPath, "/Documents") + Len("/Documents") 'find "/Documents" position in file URL
endFilePath = Mid(fullPath, iDocumentsPosition) 'get the ending file path without pointer in OneDrive
Else
'for personal onedrive it looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName, _
' by replacing "https.." with OneDrive local path obtained from registry we can get local file path
'Remove the first four backslashes
endFilePath = Mid(fullPath, 9) ' removes "https://" and with it two backslashes
For i = 1 To 2
endFilePath = Mid(endFilePath, InStr(endFilePath, "/") + 1)
Next
End If
'Replace forward slashes with back slashes (URL type to Windows type)
endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
For j = 1 To 3
oneDrivePath = Environ(Choose(j, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(oneDrivePath) > 0 Then
LocalFullName = oneDrivePath & Application.PathSeparator & endFilePath
If Dir(LocalFullName) <> "" Then
Exit Function 'that is it - WE GOT IT
End If
End If
Next j
'Possibly raise an error here when attempt to convert to a local file name fails - e.g. for "shared with me" files
LocalFullName = ""
End If
LocalFullName = fullPath
End Function
Have fun.
Hallo this is how I do it, I found my the path through "SOFTWARE\SyncEngines\Providers\OneDrive":
private static string GetLocalPath(string url)
{
try
{
var oneDriveKey = Registry.CurrentUser.OpenSubKey(@"Software\SyncEngines\Providers\OneDrive");
if (oneDriveKey != null)
{
foreach (var subKeyName in oneDriveKey.GetSubKeyNames())
{
var subKey = oneDriveKey.OpenSubKey(subKeyName);
if (subKey != null)
{
var urlNameSpace = subKey.GetValue("UrlNamespace").ToString().Trim('/');
if (url.Contains(urlNameSpace) && subKey.GetValue("MountPoint") is string localLibraryPath)
{
string restOfDocumentPath = url.Substring(urlNameSpace.Length);
restOfDocumentPath = restOfDocumentPath.Replace('/', '\\');
return localLibraryPath + restOfDocumentPath;
}
}
}
}
}
catch (Exception e)
{
Console.WriteLine(e.Message);
}
return string.Empty;
}
Here's a small improvement on Philip Swannell's improvement of Virtuoso's original answer for when the number of "\" to remove from the path is more than 4 / varies (depending on the file, i found i needed to remove 5 or sometimes 6 of these). The shortcomings mentioned by Philip are still there though.
Private Function Local_Workbook_Name(ByRef wb As Workbook) As String
'returns local wb path or nothing if local path not found
Dim i As Long
Dim OneDrivePath As String
Dim ShortName As String
Dim testWbkPath As String
Dim OneDrivePathFound As Boolean
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
ShortName = Replace(wb.FullName, "/", "\")
'Remove the first four backslashes
For i = 1 To 4
ShortName = RemoveTopFolderFromPath(ShortName)
Next
'loop through three OneDrive options
For i = 1 To 3
OneDrivePath = Environ(Choose(i, "OneDrive", "OneDriveCommercial", "OneDriveConsumer"))
If Len(OneDrivePath) > 0 Then
'Loop to see if the tentative LocalWorkbookName is the name of a file that actually exists, if so return the name
Do While ShortName Like "*\*"
testWbkPath = OneDrivePath & "\" & ShortName
If Not (Dir(testWbkPath)) = vbNullString Then
OneDrivePathFound = True
Exit Do
End If
'remove top folder in path
ShortName = RemoveTopFolderFromPath(ShortName)
Loop
End If
If OneDrivePathFound Then Exit For
Next i
Else
Local_Workbook_Name = wb.FullName
End If
If OneDrivePathFound Then Local_Workbook_Name = testWbkPath
End Function
Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid(ShortName, InStr(ShortName, "\") + 1)
End Function
Call me a hacker but the http reference on my machine is always the same so I looked at the local reference on my hard drive where the OneDrive could be found
Lets say that was C:\MyOneDrive\OneDrive then took all the other parts of the workbook path that weren't needed and added on the local part. Then switched the slash direction
folder = "C:\MyOneDrive\OneDrive" & Right(Application.ActiveWorkbook.Path, Len(Application.ActiveWorkbook.Path) - 72) & "\"
folder = Replace(folder, "/", "\")
My two lines covered all the cases on my machine!!
I solved this problem be creating a symbolic link (mklink /d). Opening files through a desktop shortcut to the link meant that WB.FullName always returned the file path using the symbolic link.
As you all seem to work on Windows-System you can also use the filescripting object:
Debug.Print
Debug.Print "ThisWorkbook.Path: "; ThisWorkbook.Path
Debug.Print "ThisWorkbook.FullName: "; ThisWorkbook.FullName
With CreateObject("Scripting.FileSystemObject")
Debug.Print "Scripting.fso: "; .GetAbsolutePathName(ThisWorkbook.Name)
End With
I solved this without VBA. Instead I used Power Query.
First I use this formula in a cell, to get the path without filename and worksheetname:
=LEFT(CELL("filename";E8);FIND("[";CELL("filename";E8))-1)
Then I import the path as a table in Power Query: "Råfilsti"
I then have another query that has this as its source. Here I do some datawrangling on the HTTPS file path. I hard coded my local OneDrive path in the query, but you can copy paste your OneDrive root folder into a cell in Excel and call that as a parameter to use in Power Query.
Then load that query into a table in the workbook.
