Visual basic Ексель Как задать относительный путь вместо абсолютного

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
     
    '????????? ?????????? ???? ?????? ?????
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "???????? ????? ??? ????"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "?? ?????? ?? ???????!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
     
    '????????? ???? ? ??????? ?? ???? ????? ???????
    ActiveWorkbook.Sheets.Add
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "??? ?????"
    Range("B1").Value = "????"
    Range("C1").Value = "??????"
    Range("D1").Value = "???? ????????"
    Range("E1").Value = "???? ?????????"
     
    '???????? ????????? ?????? ?????? ??????
    '???????? True ?? False, ???? ?? ????? ???????? ????? ?? ????????? ?????
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
 
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)
 
    r = Range("A65536").End(xlUp).Row + 1   '??????? ?????? ?????? ??????
    '??????? ?????? ?? ?????
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = "=HYPERLINK(""" & FileItem.Path & """)"
        'Cells(r, 3).Formula = FileItem.Size
        'Cells(r, 4).Formula = FileItem.DateCreated
        'Cells(r, 5).Formula = FileItem.DateLastModified
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
     
    '???????? ????????? ???????? ??? ?????? ????????? ?????
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A:E").AutoFit
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
 
End Sub

 
Public Function RelativeName$(ByVal AbsName$, Optional ByVal CurFolder$)
    '
    'Возврат относительного пути: AbsName-любой абсолютный путь; CurFolder-Папка (по умолчанию установленная системой)
    'by the fever.brain 2013
    '
    Const r$ = "\", rr$ = "..\"
    Dim fld$, a1$(), a2$(), u&, up&, i&, min&, Ign&
 
    fld = IIf(CurFolder <> vbNullString, CurFolder, CurDir$)
    a1 = Split(AbsName, r): a2 = Split(fld, r)
    min = UBound(a1): u = UBound(a2): Do While u < min: min = u: Exit Do: Loop
    For i = 0 To min
        If StrComp(a1(i), a2(i), 1) = 0 Then 'Сравнение путей
            a1(i) = "": Ign = Ign + 1
        ElseIf i = 0 Then 'Если разные драйверы (буква диска)
            RelativeName = AbsName 'Возврат полного пути
            Exit Function
        Else: up = up + 1 'Добавить если папка ещё глубже
        End If
    Next
    RelativeName = Mid$(Join(a1, r), Ign + 1) 'Отрезать путь соответствия
    For i = u + up To i Step -1: RelativeName = rr & RelativeName: Next 'Добавить трактовку
End Function

Private Sub Form_Load()
    Dim fld$, ab$
    fld = "C:\Program Files\Microsoft Visual Studio .NET 2003"
    ab = "C:\Program Files\Mozilla Firefox\firefox.exe"
    
    MsgBox "Абсолютный путь: " & ab & vbLf & _
                "Папка: " & fld & vbLf & _
                "Относителный путь: " & RelativeName(ab, fld)
End Sub

ActiveSheet.Hyperlinks.Add Cells(r, 2), FileItem.Path, , , FileItem.Name