Solved: Please help to alter some existing code

[rrenis]

Hi all,

I have the following code (which I found via google) that runs in a user form. The code lists all of the directories and sub directories of a specific folder but I would like it just to return the first level of folders i.e.

C:\Projects\Project 1\
C:\Projects\Project 2\ etc

rather than

C:\Projects\Project 1\Another Sub\Another Sub\
C:\Projects\Project 2\Another Sub\ etc

so I essentially get a list of all of my projects without their sub folders.

Does anyone know how to alter it so that it runs as described above? I've tried treaking it but all the changes I've made result in either errors or a perpetual loop!

[vba]Option Explicit
Const ARRAY_INITIAL = 1000
Const ARRAY_INCREMENT = 100
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Declare Function GetFileAttributes Lib "kernel32" Alias _
"GetFileAttributesA" (ByVal lpFileName As String) As Long
Dim arrFiles() As String
Private Sub CommandButton1_Click()
Dim X As Integer

ListBox1.Clear
ListBox1.Visible = False

Call spanFolders("C:\Projects\", "*.*")

For X = 0 To UBound(arrFiles)
ListBox1.AddItem arrFiles(X)
Next X

ListBox1.Visible = True

End Sub
Public Function spanFolders(startfolder As String, srchstr As String)

Dim sFilename As String
Dim sfoldername As String
Dim idx As Integer
Dim limit As Integer

ReDim arrFiles(ARRAY_INITIAL)
On Error GoTo errHandle

idx = 0
arrFiles(0) = startfolder
limit = 1
' get all the folder names and store in an array
Do While idx < limit
sfoldername = arrFiles(idx)
sFilename = Dir(sfoldername & srchstr, vbDirectory)
Do While sFilename <> ""

If GetFileAttributes(sfoldername & sFilename) = _
FILE_ATTRIBUTE_DIRECTORY Then
If sFilename <> "." And sFilename <> ".." Then
arrFiles(limit) = sfoldername & _
sFilename & "\"
limit = limit + 1
End If

End If
sFilename = Dir
Loop
idx = idx + 1
Loop

ReDim Preserve arrFiles(limit - 1)

Exit Function

errHandle:
If Err.Number = 9 Then
ReDim Preserve arrFiles(UBound(arrFiles) + _
ARRAY_INCREMENT)
Resume
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If

End Function
[/vba]

Also I've got the following code using some code borrowed from the KBase to verify the selected text in the userform listbox - from the results given using the above code. The selected text is then copied to the clipboard. Ideally what I'd like to do is convert the DataObject into a String before it is copied to the clipboard so it can be altered/cropped using Mid. Can anyone point me in the right direction please?

[vba]
Private Sub CommandButton2_Click()

Dim mytext As DataObject
Set mytext = New DataObject

If ListBox1.ListIndex = -1 Then
MsgBox "Nothing was selected!"
Else
MsgBox "You selected " & ListBox1.Value
End If

mytext.SetText ListBox1.Value
mytext.PutInClipboard

End Sub
[/vba]


Cheers,
rrenis

[JimmyTheHand]

Hi rrenis

I offer one of the possible solutions to the first part of your question. Copy this new function to your module.
[vba]Public Function DirLevel(fldr As String) As Long
Dim i As Long, result As Long
result = 0
For i = 1 To Len(fldr)
If Mid(fldr, i, 1) = "\" Then result = result + 1
Next
DirLevel = result
End Function[/vba]
Then modify the appropriate code line in your original code like this (additions highlighted in red):
[vba]Do While (sFilename <> "") And (DirLevel(sfoldername) < 3)[/vba]

Jimmy

[rrenis]

Thanks Jimmy!!!

That works perfectly!!

Cheers,
rrenis

[Simon Lloyd]

rrenis, i have some code that will search the drive you specify and return all the files whose extension you specify to a worksheet and create hyperlinks to them, so you can specify drive C: and specify .xls and it will return and hyperlink all files found with that extension provided they are not in password protected folders!

If you would like it i will gladly post the workbook here!

Regards,
Simon

[rrenis]

Hi Simon - If you don't mind I'd be very grateful as this is something I'd thought about a while ago but had no idea how to implement!

Cheers,
rrenis

[rrenis]

If anyone's interested here's how to copy the selected text to the clipboard (part two to my question above)...

[VBA]

Private Sub CommandButton2_Click()

Dim myRef As String
Dim mytext As DataObject
Set mytext = New DataObject

If ListBox1.ListIndex = -1 Then
MsgBox "Nothing was selected!"
Else
MsgBox "You selected " & ListBox1.Value
End If

myRef = Mid(ListBox1.Value, ' enter whatever to return the result you want
mytext.SetText myRef
mytext.PutInClipboard

End Sub

[/VBA]

Cheers,
rrenis

[Simon Lloyd]

As requested!

Regards,
Simon

[rrenis]

Thanks Simon that's a fantastic bit of code!!

Cheers,
rrenis

[Simon Lloyd]

Not entirely built by me!, i think there are some portions from perhaps the follwing (unsure of the sources) Ken Puls, Xld, Mdmackillop.

The above may or may not have contributed to that code!

Regards,
Simon