GetRelativePath

Get relative path of one to another
Pass two path strings to this function and it will return the 1st path relative to the second.
Always pass folder strings NEVER file strings
If the folder is a drive like c:\ you have to pass it without a backslash at end.

Public Function GetRelativePath(ByVal LINKINGFOLDER As String, ByVal LINKEDFOLDER As String)
 LINKINGFOLDER = LCase(LINKINGFOLDER)
 LINKEDFOLDER = LCase(LINKEDFOLDER)
 Dim OLDarrLinking As Variant
 Dim OLDarrLinked As Variant
 Dim arrLinking As Variant
 Dim arrLinked As Variant
 Dim intFolderCountLinking As Integer
 Dim intFolderCountLinked As Integer
 Dim OLDintFolderCountLinking As Integer
 Dim OLDintFolderCountLinked As Integer
 Dim Folder As Variant ' as loop variable
 Dim intCounter As Integer 'counts the folders
 Dim copyOfintCounter As Integer
 Dim prRelativePath As String
 Dim SameFolder As Boolean
 ' init
 intFolderCountLinking = -1
 intFolderCountLinked = -1
 intCounter = 0
 SameFolder = True
 '#
 ' make array out of the path
 OLDarrLinking = Split(LINKINGFOLDER, "\")
 OLDarrLinked = Split(LINKEDFOLDER, "\")
 ' whats the smaller path ?
 For Each Folder In OLDarrLinking
  intFolderCountLinking = intFolderCountLinking + 1
  OLDintFolderCountLinking = intFolderCountLinking
 Next Folder
 For Each Folder In OLDarrLinked
  intFolderCountLinked = intFolderCountLinked + 1
  OLDintFolderCountLinked = intFolderCountLinked
 Next Folder
 ' make array the same length of fields
 Select Case intFolderCountLinking
 Case intFolderCountLinked 'like case is >intfoldercountlinked AND like case is <intfoldercountlinked
  ReDim arrLinked(intFolderCountLinking)
  intCounter = -1
  For Each Folder In OLDarrLinked
    intCounter = intCounter + 1
    arrLinked(intCounter) = OLDarrLinked(intCounter)
  Next Folder
  ReDim arrLinking(intFolderCountLinked)
  intCounter = -1
  For Each Folder In OLDarrLinking
    intCounter = intCounter + 1
    arrLinking(intCounter) = OLDarrLinking(intCounter)
  Next Folder
 Case Is > intFolderCountLinked
  ReDim arrLinked(intFolderCountLinking)
  intFolderCountLinked = intFolderCountLinking
  ' fill new array with the old values
  intCounter = -1
  For Each Folder In OLDarrLinked
   intCounter = intCounter + 1
   arrLinked(intCounter) = OLDarrLinked(intCounter)
  Next Folder
  arrLinking = OLDarrLinking
 Case Is < intFolderCountLinked
  ReDim arrLinking(intFolderCountLinked)
  intFolderCountLinking = intFolderCountLinked
  ' fill new array with the old values
  intCounter = -1
  For Each Folder In OLDarrLinking
   intCounter = intCounter + 1
   arrLinking(intCounter) = OLDarrLinking(intCounter)
  Next Folder
  arrLinked = OLDarrLinked
 End Select
 '------------------------------------------------------------------------------------------------
 ' find last same root folder e.g. from c:\windows\system\test and c:\windows\something c:\windows is last same root
 ' compare from last element to first element
 intCounter = -1
 For Each Folder In arrLinked
  intCounter = intCounter + 1
  If arrLinked(intCounter) = arrLinking(intCounter) Then
  ' same
  Else
   SameFolder = False
   Exit For
  End If
 Next Folder
 If SameFolder = True Then 'exatly the same root
  GetRelativePath = ""
  Exit Function
 End If
 '------------------------------------------------------------------------------------------------
 copyOfintCounter = intCounter 'last same folder
 ' add the subfolders you have to "go" on e.g. test/test2/test3...
 Do Until copyOfintCounter = intFolderCountLinked + 1
  If arrLinked(intFolderCountLinked - _
   copyOfintCounter + intCounter) <> "" Then
   prRelativePath = arrLinked(intFolderCountLinked - _
   copyOfintCounter + intCounter) & "/" & prRelativePath
  End If
  copyOfintCounter = copyOfintCounter + 1
 Loop
 copyOfintCounter = intCounter 'last same folder
 ' add the folders (../) you have to "go" out
 For Folder = 1 To OLDintFolderCountLinking - intCounter + 1
  prRelativePath = "../" & prRelativePath
 Next Folder
 GetRelativePath = prRelativePath
End Function

Parameters

LINKINGFOLDER, LINKEDFOLDER

Examples

get_relative_path &#34;C:\My Documents&#34;, &#34;C:\Windows\System&#34;<br/>returns ../../My Documents/<br/>

Views 183 Downloads 64

Perm link