Obtain full path to a directory

[pk]

Hello, can someone help me please?

I am using VBA in Excel XP with Windows 2000.

I need to be able to return the full path to a
subdirectory given only the drive and the directory name
sought (i.e. not the path in between).

For example, I know the drive is: \\cdl\ofl\users\

I know the subdirectory I want is named: Aug03

I need code to return the full path to the subdirectory
which may be something like:

\\cdl\ofl\users\msm\work\losses\Aug03\

or like: \\cdl\ofl\users\ldw\fieldwork\Aug03\

There are two to four files in the target directory and
their names are dynamic.

Your example code would be most appreciated...thanks in
advance...

 

[keepitcool]

Following should get you u on your way

Note that you'll need a reference to
"Microsoft scripting runtime"

'--------------------------------
Option Explicit
Option Compare Text

Dim myFolders As Collection

Sub FindFolder()
Dim fso As New Scripting.FileSystemObject
Dim s As String, itm As Variant

Set myFolders = New Collection
Call FindSubFolders(fso.GetFolder("C:\"), "*\Aug03")
If myFolders.Count > 0 Then
s = " Found:" & vbNewLine
For Each itm In myFolders
s = s & itm & vbNewLine
Next
Else
s = "None found"
End If
MsgBox s
End Sub

Sub FindSubFolders(Folder As Scripting.Folder, sMask As String)
Dim subfolder As Scripting.Folder
On Error Resume Next
For Each subfolder In Folder.SubFolders
If subfolder.Path Like sMask Then myFolders.Add subfolder.Path
FindSubFolders subfolder, sMask
Next
End Sub




keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >

 

[pk]

THANKS SO MUCH! THAT'S EXACTLY WHAT I NEEDED!

-----Original Message-----

Following should get you u on your way

Note that you'll need a reference to
"Microsoft scripting runtime"

'--------------------------------
Option Explicit
Option Compare Text

Dim myFolders As Collection

Sub FindFolder()
Dim fso As New Scripting.FileSystemObject
Dim s As String, itm As Variant

Set myFolders = New Collection
Call FindSubFolders(fso.GetFolder("C:\"), "*\Aug03")
If myFolders.Count > 0 Then
s = " Found:" & vbNewLine
For Each itm In myFolders
s = s & itm & vbNewLine
Next
Else
s = "None found"
End If
MsgBox s
End Sub

Sub FindSubFolders(Folder As Scripting.Folder, sMask As String)
Dim subfolder As Scripting.Folder
On Error Resume Next
For Each subfolder In Folder.SubFolders
If subfolder.Path Like sMask Then myFolders.Add subfolder.Path
FindSubFolders subfolder, sMask
Next
End Sub




keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >




.