VBA compare two file paths and delete common root

G

Guest

I need a method for comparing two file paths and removing the common root.
Specifically, I want to create a relative path from one file to another.

I do not know in advance what the file path is or how long it is. The files
may be of different types. A typical example might be:

Path1 = S:\Workgroups\Engineering\Graphics\Pictures\Overview.bmp

Path2 = S:\Workgroups\Engineering\Trends\Spreadsheet.xls

Path3 = S:\Workgroups\Engineering\Graphics\Pictures\Sheets\Report.doc

I want to set Path1 to be the "home" location. The relative path for Path1
in my example would be:

.\Overview.bmp

The relative path from Path1 to Path2 would be:

...\Trends\Spreadsheet.xls

The relative path from Path1 to Path3 would be:

.\Sheets\Report.doc


First, I need to identify the common root. In my example, the common root is:

S:\Workgroups\Engineering\

Second, I need to replace my "Home" path path with ".\filename.ext"
In my example, I need to change my "Home" path to ".\Overview.bmp"

Third, I need to know if the path being compared is in a folder up or down
from the "home" file.

Replace EACH FOLDER ONE LEVEL UP from my "home" file with a "."

I need to replace EACH FOLDER ONE LEVEL DOWN from my "home" file -or- from
the common root with the name of the folder.

I have played with various versions of the split function, LEN(), INSTR(),
INSTREV(), LEFT(), RIGHT(), MID(), vbTextCompare, etc. without success. I
can get the full file and path name without a problem an create the "Home"
file name. It's the comparison that is tripping me up.

Any help you could provide would be greatly appreciated.

Susan Forson
 
N

NickHK

Susan,
I was under the impression there was an API call that does this, but I can't
find it now - or my memory is faulty and it does not actually exist.
Not sure if this is 100% correct, but you get the idea:

Declare Function PathIsSameRoot Lib "shlwapi.dll" Alias "PathIsSameRootA" _
(ByVal pszPath1 As String, _
ByVal pszPath2 As String) _
As Long


Public Function MakePathRelative(PathToFix As String, RelativeToPath As
String, Optional Delim As String = "\") As String
Dim RelToParts() As String
Dim FixParts() As String
Dim MinParts As Long
Dim RelToLonger As Boolean
Dim i As Long
Dim Temp As String

If PathIsSameRoot(PathToFix, RelativeToPath) = False Then
MakePathRelative = ""
Exit Function
End If

RelToParts = Split(RelativeToPath, Delim)
FixParts = Split(PathToFix, Delim)

If UBound(RelToParts) > UBound(FixParts) Then
MinParts = UBound(FixParts)
Else
MinParts = UBound(RelToParts)
End If

For i = LBound(FixParts) To MinParts
If RelToParts(i) = FixParts(i) Then
Temp = Temp & RelToParts(i) & Delim
Else
Exit For
End If
Next

MakePathRelative = WorksheetFunction.Rept("..\", UBound(RelToParts) - i + 1)
& Mid(PathToFix, Len(Temp) + 1)

End Function

Some other API that you may want to include to check the validity of input:

Declare Function PathIsRelative Lib "shlwapi.dll" Alias "PathIsRelativeA"
(ByVal pszPath As String) As Long
Declare Function PathCanonicalize Lib "shlwapi.dll" Alias
"PathCanonicalizeA" (ByVal pszBuf As String, ByVal pszPath As String) As
Long
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias
"PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function PathIsLFNFileSpec Lib "shlwapi.dll" Alias
"PathIsLFNFileSpecA" (ByVal lpName As String) As Long
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" Alias
"PathIsNetworkPathA" (ByVal pszPath As String) As Long
Private Declare Function PathIsRoot Lib "shlwapi.dll" Alias "PathIsRootA"
(ByVal pszPath As String) As Long

NickHK
 
N

NickHK

Susan,
And if you need to go the other way to combine an absolute with a relative,
try this:

Declare Function PathCombine Lib "shlwapi.dll" Alias "PathCombineA" _
(ByVal szDest As String, _
ByVal lpszDir As String, _
ByVal lpszFile As String) _
As Long

Public Function TestRelativePath(Base As String, Rest As String) As String
Dim Temp As String

Const MAX_PATH = 255
Temp = String(MAX_PATH, 0)

PathCombine Temp, Base, Rest

TestRelativePath = StripTerminator(Temp)

End Function

'Remove all trailing Chr$(0)'s
Function StripTerminator(sInput As String) As String
Dim ZeroPos As Long
ZeroPos = InStr(1, sInput, Chr$(0))
If ZeroPos > 0 Then
StripTerminator = Left$(sInput, ZeroPos - 1)
Else
StripTerminator = sInput
End If
End Function

You will find the API-Guide invaluable for these declaration and examples:
Their site at http://www.allapi.net/ seems to been taken over, so I can't
tell you where to get it now, but a search should show some other sites.

NickHK
 
G

Guest

Thanks for the prompt reply. I will try it and let you know. Sometimes I
wonder why I beat myself up so long before I ask for help - you guys are
AWESOME!

Susan
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top