A family of Microsoft spreadsheet software with tools for analyzing, charting, and communicating data
Sorry, my mistake. The code works like a charm in Word too, replacing the string "workbook" with "document", and removing all debugging (as it was written to log stuff in an Excel worksheet), including removing "Dim Calculation As XlCalculation" and removing the LogWorksheet argument from FileExists (which I somehow had messed up before).
Here's the code:
Option Explicit
'-------------------------------------------------------------------------------
'
' Function OneDriveLocalFilePath( ...
'
' Fix that .path doesn't work when the file is in a OneDrive folder.
'
'Code adapted from forum post by Kevin Zvorek 2024-07-02
'https://answers.microsoft.com/en-us/msoffice/forum/all/the-onedrive-nightmare-continues-thisworkbookpath/3350ec2c-e75b-4bfd-acb7-d6ce71bd9c51
'-------------------------------------------------------------------------------
Public Function OneDriveLocalFilePath( _
Optional ByRef OneDriveFilePath As String, _
Optional ByVal ReturnFolderPathOnly As Boolean, _
Optional ByVal ReturnEmptyIfFileNotFound As Boolean _
) As String
' Kevin Zvorek 2024-07-02
'
' Returns the local file path given a URL to a file stored in a OneDrive or Sharepoint folder. For
' some reason the Excel document properties Path and FullName return URLs instead of local paths.
'
' OneDriveFilePath - Any valid local path or URL referencing a OneDrive file. If the path cannot be
' resolved, the original path is returned.
'
' ReturnFolderPathOnly - Pass True to return the folder path only. This is the equivelant of
' Thisdocument.Path. Optional. If omitted then False is assumed.
'
' ReturnEmptyIfFileNotFound - Pass True to return an empty or null string if the file cannot be
' found, False to return an error message. Optional. If omitted then False is assumed.
Const RegistryPath As String = "HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive\"
Dim ScreenUpdating As Boolean
Dim EnableEvents As Boolean
Dim WScript As Object
Dim WinMgmtS As Object
Dim Result As String
Dim ProposedFilePath As String
Dim ConfirmedFilePath As String
Dim RegistryKey As Variant
Dim RegistryKeys As Variant
Dim Types As Variant
Dim CID As String
Dim MountPoint As String
Dim URLNamespace As String
Dim LibraryType As String
Dim URLNameSpaceExtended As String
Dim LocalPartialPath As String
Dim PartialPathRootDirectory As String
Dim LocalPartialPathWithFirstFolder As String
Dim LocalPartialPathWithoutFirstFolder As String
Dim Pass As Long
Dim ExistsCount As Long
Dim EntryCount As Long
' Default to the full name property of Thisdocument
If Len(OneDriveFilePath) = 0 Then
OneDriveFilePath = ThisDocument.FullName
End If
' Determine if the path is a URL or a local path
If Left(OneDriveFilePath, 8) = "https://" Then
' WScript and Winmgmts are used to navigate the registry
Set WScript = CreateObject("WScript.Shell")
Set WinMgmtS = GetObject("Winmgmts:root\default:StdRegProv")
For Pass = 1 To 2
ExistsCount = 0
' Enumerate the key HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive
If WinMgmtS.EnumKey(&H80000001, Mid(RegistryPath, InStr(RegistryPath, "\") + 1), RegistryKeys, Types) = 0 Then
EntryCount = 0
For Each RegistryKey In RegistryKeys
' Each key has three values of interest:
'
' CID - Some hash code sometimes used in the path
' URLNameSpace - The URL to a parent directory in the cloud
' MountPoint - The local path OneDrive uses to mirror files found in the URLNameSpace address
CID = vbNullString
MountPoint = vbNullString
URLNamespace = vbNullString
ProposedFilePath = vbNullString
On Error Resume Next
CID = WScript.RegRead(RegistryPath & RegistryKey & "\CID")
MountPoint = WScript.RegRead(RegistryPath & RegistryKey & "\MountPoint")
URLNamespace = WScript.RegRead(RegistryPath & RegistryKey & "\URLNamespace")
LibraryType = WScript.RegRead(RegistryPath & RegistryKey & "\LibraryType")
On Error GoTo 0
EntryCount = EntryCount + 1
' Remove any trailing slash from the URL name space
If Right(URLNamespace, 1) = "/" Then
URLNamespace = Left(URLNamespace, Len(URLNamespace) - 1)
End If
' Determine the extended URL name space which may or may not include the CID
If Len(CID) = 0 Then
URLNameSpaceExtended = URLNamespace
Else
URLNameSpaceExtended = URLNamespace & "/" & CID
If Left(OneDriveFilePath, Len(URLNameSpaceExtended)) <> URLNameSpaceExtended Then
URLNameSpaceExtended = URLNamespace
End If
End If
' Looking for a local file path only if the base of the path being evaluated matches the extended URL name space
If Left(OneDriveFilePath, Len(URLNameSpaceExtended)) = URLNameSpaceExtended Then
LocalPartialPath = Mid(OneDriveFilePath, Len(URLNameSpaceExtended) + 2)
' It's not always clear if the first directory in the partial path is used locally, it may be a firectory only in the cloud to distinguish directories shared by others
If InStr(LocalPartialPath, "/") > 0 Then
PartialPathRootDirectory = Left(LocalPartialPath, InStr(LocalPartialPath, "/") - 1)
Else
PartialPathRootDirectory = vbNullString
End If
If Pass = 1 Or Pass = 2 And LibraryType = "teamsite" And Right(MountPoint, Len(PartialPathRootDirectory)) = PartialPathRootDirectory Then
' Build two local partial paths: one with the first folder after the mount point, and the second without the first folder after the mount point
LocalPartialPathWithFirstFolder = Replace(Replace(Mid(OneDriveFilePath, Len(URLNameSpaceExtended) + 2), "/", "\"), "%20", Space(1))
LocalPartialPathWithoutFirstFolder = Mid(LocalPartialPathWithFirstFolder, InStr(LocalPartialPathWithFirstFolder, "\") + 1)
If LocalPartialPathWithFirstFolder = LocalPartialPathWithoutFirstFolder Then
LocalPartialPathWithFirstFolder = vbNullString
End If
If OneDriveLocalFilePath_FileExists(MountPoint & "\" & LocalPartialPathWithoutFirstFolder, ConfirmedFilePath, ExistsCount) Then Exit For
If Len(LocalPartialPathWithFirstFolder) > 0 Then
If OneDriveLocalFilePath_FileExists(MountPoint & "\" & LocalPartialPathWithFirstFolder, ConfirmedFilePath, ExistsCount) Then Exit For
End If
End If
End If
Next RegistryKey
' Return the confirmed file path if a valid path was found
If Len(ConfirmedFilePath) > 0 Then
If ReturnFolderPathOnly Then
Result = Left(ConfirmedFilePath, InStrRev(ConfirmedFilePath, "\") - 1)
Else
Result = ConfirmedFilePath
End If
End If
Else
Result = OneDriveFilePath
End If
If ExistsCount < 2 Then Exit For
Next Pass
Else
' The path is not a URL so return it as-is
Result = OneDriveFilePath
End If
If ExistsCount = 0 Then
If Not ReturnEmptyIfFileNotFound Then
Result = "A local file path to an existing file was not found."
End If
End If
OneDriveLocalFilePath = Result
End Function
Private Function OneDriveLocalFilePath_FileExists( _
ByRef ProposedFilePath As String, _
ByRef ConfirmedFilePath As String, _
ByRef ExistsCount As Long _
) As Boolean
' Kevin Zvorek 2024-07-02
' Tests if file path exists. Internal use only.
If ProposedFilePath = ConfirmedFilePath Then Exit Function
If ExistingFile(ProposedFilePath) Then
ConfirmedFilePath = ProposedFilePath
ExistsCount = ExistsCount + 1
End If
End Function
Public Function ExistingFile( _
ByVal FilePath As String _
) As Boolean
' Kevin Zvorek 2024-07-02
' Return True if the file exists, False otherwise. This routine does not use the Dir technique as
' the Dir function resets any current Dir process.
'
' FilePath - Full path to the folder or file to be evaluated.
Dim Attributes As Long
On Error Resume Next
Attributes = GetAttr(FilePath)
ExistingFile = (Err.Number = 0) And (Attributes And vbDirectory) = 0
Err.Clear
End Function
'-------------------------------------------------------------------------------