rrenis
05-02-2007, 03:15 AM
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! :banghead:
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
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?
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
Cheers,
rrenis
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! :banghead:
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
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?
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
Cheers,
rrenis