Относительные пути

ChDir ("C:\Documents and Settings\")
ChDrive ("H:\")

Public Function RelativeName$(AbsName$, Optional RelativeFolder$)
    'Создание относительного пути
    'Арг: Полный путь // Относительная папка
    
    Dim MyDir$, j$(), j1$(), f&, ubnj&, ubnj1&
    Const r$ = "\", rp$ = "..\"
    MyDir = IIf(RelativeFolder <> "", RelativeFolder, CurDir$)
    j = Split(AbsName, r): j1 = Split(MyDir, r)
    ubnj = UBound(j): ubnj1 = UBound(j1)
    For f = 0 To ubnj
        If f > ubnj1 Then GoTo 20
        If j(f) <> j1(f) Then GoTo 10
    Next
10
    For f = f To ubnj 'Запись верхних папок ..\ + путь откуда пошла развилка
        RelativeName = rp & RelativeName & j(f) & IIf(f < ubnj, r, "")
    Next
    Exit Function
20
    For f = f To ubnj 'Запись пути после относительной папки
        RelativeName = RelativeName & j(f) & IIf(f < ubnj, r, "")
    Next
End Function

Option Explicit
 
Public Function RelativeName$(AbsName$, Optional RelativeFolder$)
    'Создание относительного пути
    'Арг: Полный путь // Относительная папка [Текущая по умолчанию]
    
    Const r$ = "\", rp$ = "..\"
    Dim MyDir$, ja$(), jr$(), ua&, ur&, f&, Min&, AdUp&, Ign&
    
    MyDir = IIf(RelativeFolder <> vbNullString, RelativeFolder, CurDir$)
    ja = Split(AbsName, r): jr = Split(MyDir, r)
    ua = UBound(ja): ur = UBound(jr)
    Min = IIf(ua < ur, ua, ur) 'верхний индекс для обоих путей
    For f = 0 To Min
        If StrComp(ja(f), jr(f), vbTextCompare) = 0 Then 'Сравнение +игнор. регистра
            ja(f) = vbNullString: Ign = Ign + 1
        ElseIf f = 0 Then 'Если разные драйверы (буква диска)
            RelativeName = AbsName 'Возврат полного пути
            Exit Function
        Else: AdUp = AdUp + 1 'Добавить если папка ещё глубже
        End If
    Next
    RelativeName = Mid$(Join(ja, r), Ign + 1) 'Отрезать путь соответствия
    For f = ur + AdUp To f Step -1 'Добавить трактовку
        RelativeName = rp & RelativeName
    Next
End Function
 
 
Private Sub Form_Load()
    '
    '   Тестирование моей функции RelativeName
    '
    Dim absN$, relF$, result$, o As Object
    Set o = CreateObject("Scripting.FileSystemObject")
    '=================================
1
    absN = "C:\WINDOWS\system32"
    relF = "C:\Program Files\Microsoft Visual Studio\VB98"
    result = RelativeName(absN, relF)
    ChDir (relF) 'Установить текущую
    Debug.Print "Пример 1 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
2
    absN = "C:\Program Files\Microsoft Visual Studio\VB98"
    relF = "C:\WINDOWS\system32"
    result = RelativeName(absN, relF)
    ChDir (relF)
    Debug.Print "Пример 2 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
3
    absN = "C:\WINDOWS\system32\SHELL32.dll"
    relF = "C:\Program Files\Microsoft Visual Studio\VB98"
    result = RelativeName(absN, relF)
    ChDir (relF)
    Debug.Print "Пример 3 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
    Stop 'Остановка /// просмотр окна Immediate
End Sub