Convert Sharepoint/Onedrive urls in ThisWorkbook.FullName to local filepaths VBA

PathParsing.bas

Attribute VB_Name = "PathParsing"
'@Folder("GetPath.Core")
Option Explicit
Option Private Module

Private Enum PathType
    OneDriveConsumer
    OneDriveCommercial
    OneDrive
    LocalPath
    LocalFile
    Unrecognised
End Enum

Public Enum LocalPathParsingErrors
    [_Base] = vbObjectError                      'sets all subsequent error numbers to be in the custom range
    OneDriveFolderOrFileDoesNotExistLocallyError
    UnrecognisedLocalPathError
    TrimOneDrivePathError
    OneDriveNotInEnvironError
End Enum

Private Const webAddressPrefix As String = "https://"
Private Const slashesInPrefix As Long = 2

Private Sub RaiseCustomError(ByVal errorCode As LocalPathParsingErrors, Optional ByVal source As String = "PathParsing")
    Dim unformattedErrorText As String
    Select Case errorCode
        Case OneDriveFolderOrFileDoesNotExistLocallyError, UnrecognisedLocalPathError
            unformattedErrorText = "Failed to convert to valid local path, path may not exist locally"

        Case TrimOneDrivePathError
            unformattedErrorText = "Unexpected number of `/` in OneDrive string"

        Case OneDriveNotInEnvironError
            unformattedErrorText = "No relevant reference to OneDrive was found in the Environ registry (local path variables)"

        Case Else
            unformattedErrorText = Error$(errorCode)

    End Select
    Err.Raise errorCode, source, unformattedErrorText

End Sub

'@Description("Converts a Local, OneDrive or OneDrive for Business path to an absolute local one. Throws an error if format is invalid or path does not exist"
Public Function GetLocalPath(ByVal source As String) As String
    Const ERROR_SOURCE As String = "GetLocalPath"

    Dim pathTypeEnumVal As PathType
    pathTypeEnumVal = getPathType(source)

    Dim result As String
    Static fso As New FileSystemObject

    Select Case pathTypeEnumVal
        Case PathType.LocalPath, PathType.LocalFile
            result = source

        Case PathType.OneDriveCommercial, PathType.OneDriveConsumer
            result = fso.BuildPath(LocalStemFromRegistry(pathTypeEnumVal), TrimOffWebStuff(source, pathTypeEnumVal))
            Select Case getPathType(result)      'check return path is now parsed as local
                Case LocalPath, LocalFile:       'conversion successful
                Case Else: RaiseCustomError OneDriveFolderOrFileDoesNotExistLocallyError, ERROR_SOURCE
            End Select

        Case Else
            RaiseCustomError UnrecognisedLocalPathError, ERROR_SOURCE

    End Select
    GetLocalPath = fso.GetAbsolutePathName(result)

End Function

Private Function TrimOffWebStuff(ByVal fullPath As String, ByVal pathTypeEnumVal As PathType) As String
    Dim countOfSlashesInStemSection As Long
    Select Case pathTypeEnumVal
        Case PathType.OneDriveCommercial
            countOfSlashesInStemSection = 6

        Case PathType.OneDriveConsumer
            countOfSlashesInStemSection = 4

        Case Else                                'we shouldn't be here
            Err.Description = "Only OneDrive PathTypes are valid for this function"
            Err.Raise 5

    End Select

    Dim currentSearchStartingIndex As Long
    currentSearchStartingIndex = Len(webAddressPrefix) 'start after https:// or whatever prefix is universal

    Dim slashIndex As Long
    For slashIndex = slashesInPrefix + 1 To countOfSlashesInStemSection 'loop to find final slash, skip the first 2 though
        currentSearchStartingIndex = InStr(currentSearchStartingIndex + 1, fullPath, "/")
        If currentSearchStartingIndex = 0 Then RaiseCustomError TrimOneDrivePathError
    Next slashIndex

    TrimOffWebStuff = Mid$(fullPath, currentSearchStartingIndex)
End Function

'@Description("Get environ string for OneDrive path, resort to basic OneDrive path if Consumer/Commercial not found")
Private Function LocalStemFromRegistry(ByVal enumVal As PathType) As String
Attribute LocalStemFromRegistry.VB_Description = "Get environ string for OneDrive path, resort to basic OneDrive path if Consumer/Commercial not found"
    Dim result As String
    Select Case enumVal
        Case PathType.OneDriveConsumer, PathType.OneDriveCommercial
            result = Environ$(GetEnvironVariableName(enumVal))
            If result = vbNullString Then result = LocalStemFromRegistry(OneDrive) 'try more general version

        Case PathType.OneDrive
            result = Environ$(GetEnvironVariableName(enumVal))

        Case Else                                'we shouldn't be here
            Err.Description = "Only OneDrive PathTypes are valid for this function"
            Err.Raise 5

    End Select

    If result = vbNullString Then
        RaiseCustomError OneDriveNotInEnvironError, "LocalStemFromRegistry"
    Else
        LocalStemFromRegistry = result
    End If
End Function

Private Function GetEnvironVariableName(ByVal enumVal As PathType) As String
    Select Case enumVal
        Case PathType.OneDriveConsumer
            GetEnvironVariableName = "OneDriveConsumer"

        Case PathType.OneDriveCommercial
            GetEnvironVariableName = "OneDriveCommercial"

        Case PathType.OneDrive
            GetEnvironVariableName = "OneDrive"

        Case Else
            Err.Raise 5

    End Select
End Function

Private Function getPathType(ByVal path As String) As PathType
    If StringContains(webAddressPrefix, path) Then
        Const commercialOneDriveID As String = "sharepoint.com/"
        If StringContains(commercialOneDriveID, path, start:=8) Then 'skip the https bit
            getPathType = OneDriveCommercial

        Else
            getPathType = OneDriveConsumer

        End If
    Else                                         'local path, check it is valid
        Dim fso As New FileSystemObject
        If fso.FolderExists(path) Then
            getPathType = LocalPath

        ElseIf fso.FileExists(path) Then
            getPathType = LocalFile

        Else
            getPathType = Unrecognised

        End If
    End If
End Function

Private Function StringContains(ByVal needle As String, ByVal haystack As String, Optional ByVal Compare As VbCompareMethod = vbTextCompare, Optional ByVal start As Long = 1) As Boolean
    StringContains = InStr(start, haystack, needle, Compare) <> 0
End Function

WorksheetFunctions.bas

Attribute VB_Name = "WorksheetFunctions"
'@Folder("GetPath.Macros")
Option Explicit

'@Description(Excel worksheet function to convert onedrive files/folders to local paths. Local paths will pass through silently. Returns #REF if Local file is missing, #NA if onedrive link is malformed, #CONNECT if OneDrive not in environment variables, #VALUE on unexpected errors)
Public Function ConvertToLocalPath(ByVal folderOrFilePath As String) As Variant
    On Error GoTo convertException
    ConvertToLocalPath = PathParsing.GetLocalPath(folderOrFilePath)
    
CleanExit:
    Exit Function
    
convertException:
    Select Case Err.Number
        Case LocalPathParsingErrors.OneDriveFolderOrFileDoesNotExistLocallyError _
             , LocalPathParsingErrors.UnrecognisedLocalPathError
            ConvertToLocalPath = CVErr(XlCVError.xlErrRef) 'parse was fine but file doesn't exist
        
        Case TrimOneDrivePathError
            ConvertToLocalPath = CVErr(XlCVError.xlErrNA) 'this approach can't parse that web address
        
        Case OneDriveNotInEnvironError
            ConvertToLocalPath = CVErr(XlCVError.xlErrConnect) 'OneDrive not installed in usual place
        
        Case Else
            Err.Raise Err.Number                 'rethrow as this is a genuine unexpected error
    
    End Select
    Resume CleanExit
    
End Function

'@EntryPoint
Public Function ThisWorkbookFullPath() As Variant
    ThisWorkbookFullPath = ConvertToLocalPath(ThisWorkbook.FullName)
End Function

'@EntryPoint
Public Function ThisWorkbookParentDirectory() As Variant
    ThisWorkbookParentDirectory = ConvertToLocalPath(ThisWorkbook.path)
End Function