Excel's fullname property with OneDrive

Question

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 in

Answer 1

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")