How to test if a directory exist in qbasic? - directory

I'm writing a program in Qbasic.
I'd like to know how to test if a folder exists.
The idea is:
IF "c:\user\basic\blablabla\" exists (?? how to programm the "exist" test?)
THEN CHDIR "c:\user\basic\blablabla\"
ELSE
MKDIR "c:\user\basic\blablabla\"
CHDIR "c:\user\basic\blablabla\"
ENDIF
I hope i'm clear enough,
thank you very much for your suggestions !
:)

Try changing the directory to blablabla. If it doesn't exist, there'll be an error. Trap this error and specify an error handling routine.
ON ERROR GOTO doesnotexist
CHDIR "c:\user\basic\blablabla\"
END
doesnotexist:
MKDIR "c:\user\basic\blablabla\"
CHDIR "c:\user\basic\blablabla\"
RESUME NEXT

If memory serves (and it sometimes doesn't):
FolderExists = (Dir$("C:\User\basic\blahblahbla\nul") <> "")
should work in older versions of BASIC that support Dir$() but don't support the attribute parameter. The NUL device is assumed to exist in every folder, so it's a way to check for a folder, even if that folder is empty.

Another way to detect directory exists in QB:
REM function to detect directory exists in QB pd 2019 ejo
REM load QB /L QB.QLB
TYPE DTAtype
Drive AS STRING * 1
SearchTemplate AS STRING * 11
SearchAttr AS STRING * 1
EntryCount AS STRING * 2
ClusterNumber AS STRING * 2
Reserved AS STRING * 4
Filebits AS STRING * 1
FileTime AS STRING * 2
FileDate AS STRING * 2
FileSize AS STRING * 4
ASCIIZfilename AS STRING * 13
END TYPE
TYPE RegTypeX
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
DECLARE SUB InterruptX (intnum AS INTEGER, inreg AS RegTypeX, outreg AS RegTypeX)
DIM InregsX AS RegTypeX
DIM OutregsX AS RegTypeX
DIM DTAfile AS DTAtype
DIM ASCIIZ AS STRING * 260
DIM Current.DTA.SEG AS INTEGER
DIM Current.DTA.OFF AS INTEGER
PRINT "Enter directory";
INPUT Filespec$
ASCIIZ = Filespec$ + CHR$(0)
' store current dta
InregsX.AX = &H2F00
CALL InterruptX(&H21, InregsX, OutregsX)
Current.DTA.SEG = OutregsX.ES
Current.DTA.OFF = OutregsX.BX
' store function dta
InregsX.AX = &H1A00
InregsX.DS = VARSEG(DTAfile)
InregsX.DX = VARPTR(DTAfile)
CALL InterruptX(&H21, InregsX, OutregsX)
' findfirst
InregsX.AX = &H4E00
InregsX.CX = &H37
InregsX.DS = VARSEG(ASCIIZ)
InregsX.DX = VARPTR(ASCIIZ)
CALL InterruptX(&H21, InregsX, OutregsX)
' check carry flag error
IF (OutregsX.flags AND &H1) = &H0 THEN
' store filename attribute bits
Filebits% = ASC(DTAfile.Filebits)
' check directory bit
IF (Filebits% AND &H10) = &H10 THEN
PRINT "Directory exists."
ELSE
PRINT "Filename exists."
END IF
ELSE
PRINT "Filespec not found."
END IF
' restore current dta
InregsX.AX = &H1A00
InregsX.DS = Current.DTA.SEG
InregsX.DX = Current.DTA.OFF
CALL InterruptX(&H21, InregsX, OutregsX)
END

Another subroutine to count directories/filenames in QB45:
DECLARE SUB CheckSpec (Var$, Var1!, Var2!)
REM subroutine to count directories\filenames in QB pd 2019 ejo
REM load QB /L QB.QLB
REM links qb.lib into qb.qlb
REM link /q qb.lib,qb.qlb,Nul,bqlb45.lib;
TYPE DTAtype
Drive AS STRING * 1
SearchTemplate AS STRING * 11
SearchAttr AS STRING * 1
EntryCount AS STRING * 2
ClusterNumber AS STRING * 2
Reserved AS STRING * 4
Filebits AS STRING * 1
FileTime AS STRING * 2
FileDate AS STRING * 2
FileSize AS STRING * 4
ASCIIZfilename AS STRING * 13
END TYPE
TYPE RegTypeX
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
DECLARE SUB InterruptX (intnum AS INTEGER, inreg AS RegTypeX, outreg AS RegTypeX)
DO
COLOR 15, 0
PRINT "Enter filespec(*.*)";
INPUT Filespec$
IF Filespec$ = "" THEN Filespec$ = "*.*"
COLOR 14, 0
PRINT "Searching: "; Filespec$
CALL CheckSpec(Filespec$, Var1, Var2)
COLOR 15, 0
IF Var1 THEN PRINT "Directories:"; Var1
IF Var2 THEN PRINT "Filenames:"; Var2
IF Var1 = 0 AND Var2 = 0 THEN PRINT "No files foound."
COLOR 14, 0
PRINT "Again(y/n)?";
LOCATE , , 1
DO
x$ = INKEY$
IF LCASE$(x$) = "n" THEN PRINT : COLOR 7, 0: END
IF LCASE$(x$) = "y" THEN PRINT : COLOR 7, 0: EXIT DO
LOOP
LOOP
END
' var1=dirs, var2=files
SUB CheckSpec (Var$, Var1, Var2)
DIM InregsX AS RegTypeX
DIM OutregsX AS RegTypeX
DIM DTAfile AS DTAtype
DIM ASCIIZ AS STRING * 260
DIM Current.DTA.SEG AS INTEGER
DIM Current.DTA.OFF AS INTEGER
ASCIIZ = UCASE$(Var$) + CHR$(0)
Var1 = 0: Var2 = 0
' store current dta
InregsX.AX = &H2F00
CALL InterruptX(&H21, InregsX, OutregsX)
Current.DTA.SEG = OutregsX.ES
Current.DTA.OFF = OutregsX.BX
' store function dta
InregsX.AX = &H1A00
InregsX.DS = VARSEG(DTAfile)
InregsX.DX = VARPTR(DTAfile)
CALL InterruptX(&H21, InregsX, OutregsX)
' findfirst
InregsX.AX = &H4E00
InregsX.CX = &H37
InregsX.DS = VARSEG(ASCIIZ)
InregsX.DX = VARPTR(ASCIIZ)
CALL InterruptX(&H21, InregsX, OutregsX)
' check carry flag error
DO
IF (OutregsX.flags AND &H1) = &H0 THEN
' store filename attribute bits
Filebits% = ASC(DTAfile.Filebits)
' check directory bit
IF (Filebits% AND &H10) = &H10 THEN
Var1 = Var1 + 1
ELSE
Var2 = Var2 + 1
END IF
' find next filename
InregsX.AX = &H4F00
CALL InterruptX(&H21, InregsX, OutregsX)
ELSE
EXIT DO
END IF
LOOP
' restore current dta
InregsX.AX = &H1A00
InregsX.DS = Current.DTA.SEG
InregsX.DX = Current.DTA.OFF
CALL InterruptX(&H21, InregsX, OutregsX)
END SUB

Another sample to detect directory exists in QB64:
PRINT "Enter dirspec";: INPUT Spec$
IF _DIREXISTS(Spec$) THEN
PRINT "Directory exists."
ELSE
PRINT "Directory not found."
END IF
END

Related

What's the best way to parse an SQL fragment string into a List(of string) for a Listbox control?

I'm trying to take this string:
(("DISPLAY_NAME" like N'sadf%') And ("ID" = 2) And ("IsCRITERION" = null))
and parse it into a List(of string) so that it can be displayed like:
(
(
"DISPLAY_NAME" like N'sadf%'
)
And
(
"ID" = 2
)
Or
(
"IsCRITERION" = null
)
)
I'm close but don't quite have it. My code currently looks like:
Dim filterlist As New List(Of String)
Dim temp As String = String.Empty
Dim lvl As Integer = 0
Dim pad As String = String.Empty
For Each chr As Char In originalString '--- filter is the string i posted above
Select Case chr.ToString.ToLower()
Case "("
filterlist.Add(pad.PadLeft(lvl * 5) & chr)
lvl += 1
Case ")"
filterlist.Add(pad.PadLeft(lvl * 5) & temp)
If lvl > 0 Then lvl -= 1
filterlist.Add(pad.PadLeft(lvl * 5) & chr)
'If lvl > 0 Then lvl -= 1
temp = String.Empty
Case Else
temp &= chr
End Select
Next
'--- Removes the empty line produced by generating the List(of String)
filterlist = filterlist.Where(Function(s) Not String.IsNullOrWhiteSpace(s)).ToList()
listSelectedCriteria.DataSource = filterlist
listSelectedCriteria.DataBind()
Unfortunately, the above code produces something close to what I desire but the "And"s and "Or"s are not in the right places:
(
(
"DISPLAY_NAME" like N'sadf%'
)
(
And "ID" = 2
)
(
Or "IsCRITERION" = null
)
)
Would using regular expressions be better? Thanks for the help
Probably the "best" way (although that's getting into "primarily opinion-based" territory) would be to use a parser, but assuming that your input is limited to similar looking strings, here's what I came up with:
Dim originalString = "((""DISPLAY_NAME"" like N'sadf%') And (""ID"" = 2) And (""IsCRITERION"" = null))"
Dim filterlist = New List(Of String)()
Dim temp = New StringBuilder()
Dim lvl = 0
Dim addLine =
Sub(x As String)
filterlist.Add(New String(" ", lvl * 4) & x.Trim())
End Sub
For Each c In originalString
Select Case c
Case "("
If temp.Length > 0 Then
addLine(temp.ToString())
temp.Clear()
End If
addLine("(")
lvl += 1
Case ")"
If temp.Length > 0 Then
addLine(temp.ToString())
temp.Clear()
End If
lvl -= 1
addLine(")")
Case Else
temp.Append(c)
End Select
Next
If temp.Length > 0 Then
addLine(temp.ToString())
temp.Clear()
End If
filterlist.Dump() ' LINQPad ONLY
This results in:
(
(
"DISPLAY_NAME" like N'sadf%'
)
And
(
"ID" = 2
)
And
(
"IsCRITERION" = null
)
)
However, you will probably end up having to add code as you find different inputs that don't quite work how you want.
Instead of looking at each characters, I would start be doing a split. And then add/remove padding depending on what character is at the start.
Dim tempString As String = "((""DISPLAY_NAME"" like N'sadf%') And (""ID"" = 2) And (""IsCRITERION"" = null))"
Dim curPadding As String = ""
Const padding As String = " "
Dim result As New List(Of String)
For Each s As String In Text.RegularExpressions.Regex.Split(tempString, "(?=[\(\)])")
If s <> "" Then
If s.StartsWith("(") Then
result.Add(curPadding & "(")
curPadding &= padding
result.Add(curPadding & s.Substring(1).Trim())
ElseIf s.StartsWith(")") Then
curPadding = curPadding.Substring(padding.Length)
result.Add(curPadding & ")")
result.Add(curPadding & s.Substring(1).Trim())
Else
result.Add(curPadding & s)
End If
End If
Next

Why I got this massage "too few parameters. expected 1"? in MS Access

My database has:
Table name “Books”
Query name “BooksQMiss”
Form name “100” which has a combo name “Combo0”
The query has the following fields:
Field name "Serial"
Field name “Section”
I use the below module to find the gaps in field "Serial" with a criteria inserted in “Section” field:
[Forms]![100]![Combo0]
Query name “BooksQMiss”
Function FindGaps()
Dim mydb As Database
Dim mytbl As Recordset
Dim mytbl2 As Recordset
Dim lastnum As Integer
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE Lost_Number.* FROM Lost_Number;"
DoCmd.SetWarnings True
Set mydb = DBEngine.Workspaces(0).Databases(0)
Set mytbl = mydb.OpenRecordset("BooksQMiss") ' The problem is here
Set mytbl2 = mydb.OpenRecordset("Lost_number")
With mytbl
.MoveFirst
lastnum = 1
Do Until .EOF
If !Serial - lastnum >= 1 Then
Do
If mytbl!Serial - lastnum = 0 Then Exit Do
With mytbl2
.AddNew
!missing = lastnum
.Update
End With
lastnum = lastnum + 1
Loop
lastnum = lastnum + 1
.MoveNext
Else
lastnum = !Serial + 1
.MoveNext
End If
Loop
End With
mytbl.Close
mytbl2.Close
Set mytbl = Nothing
Set mytbl2 = Nothing
Set mydb = Nothing
DoCmd.OpenForm "frm-Lost_Number", acNormal, "", "", , acNormal
End Function
My question is why I got this massage "too few parameters. expected 1"?
Anyone can help!
Thank you.

Call function recursively without additional parameter

I wrote vbscript function which search the list of free ports on Unix. So my code looks like this:
Function FindFreePorts(ByVal intPortToStart, ByVal intCountOfPortToSearch, ByVal arrFreePorts)
Dim i, arrCommand, arrTmp, blnFindAllPort, j, strCommand
Dim blnFree, intCountOfFreePorts
strCommand = "lsof -i | awk '{print $8}' | sed -n '/"
For i = intPortToStart To intPortToStart+intCountOfPortToSearch - 1
If i = intPortToStart+intCountOfPortToSearch - 1 Then
strCommand = strCommand & ".*"& i & "$/s/.*://p'"
Else
strCommand = strCommand & ".*:" & i &"\|"
End If
Next
Push arrCommand, strCommand
arrTmp = Array()
arrTmp = ExecuteCommandOnUnix(arrCommand, Null, _
Environment.Value("UNIXHOST_NAME"), _
Environment.Value("UNIXHOST_USER"), _
Environment.Value("UNIXHOST_PWD"))
' Count of busy port is UBound(arrTmp) - the other ports are free
' Find free ports
intCountOfFreePorts = intCountOfPortToSearch
For i = intPortToStart To intPortToStart+intCountOfPortToSearch - 1
blnFree = True
For j = 0 To UBound(arrTmp)
If arrTmp(j) = CStr(i) Then
blnFree = False
j = UBound(arrTmp)
End If
Next
If blnFree Then
Push arrFreePorts, i
intCountOfFreePorts = intCountOfFreePorts - 1
End If
Next
'
If intCountOfFreePorts = 0 Then
blnFindAllPort = True
Else
blnFindAllPort = False
End If
If Not blnFindAllPort Then
' We found UBound(arrFreePorts), we need to find intCountOfPortToSearch - UBound(arrFreePorts)
Do While intCountOfPortToSearch - UBound(arrFreePorts) - 1 <> 0
arrFreePorts = FindFreePorts(intPortToStart + intCountOfPortToSearch + 1, intCountOfPortToSearch - UBound(arrFreePorts) - 1, arrFreePorts)
If intCountOfPortToSearch - UBound(arrFreePorts) - 1 = 0 Then
Exit Do
End If
Loop
End If
FindFreePorts = arrFreePorts
End Function
As you can see I call this function recursively in Do While cycle. Everything works ok but I don't like arrFreePorts parameter here. So I should write this code to execute my function:
arrPort = FindFreePorts(intStartFromPort, intCountToSearch, arrPort)
But I have no idea how to rewrite this function without this parameter. Then I could call it in more simple way:
arrPort = FindFreePorts(intStartFromPort, intCountToSearch)
Thanks in advance.
To keep things (experiments, illustration of #Bond's contribution) simple, let's consider the task of putting the chars of a string into an array.
A function that shall return an array (without getting it via parameter or global) needs to create the array:
Function f1(s) ' default ByRef is ok, because Left and Mid return new (sub)strings
If "" = s Then
f1 = Array() ' return empty array for empty string
Else
Dim t : t = f1(Mid(s, 2)) ' recurse for tail - sorry no tail recursion
f1 = cons(Left(s, 1), t) ' copy! result of cons to f1/function's return value
End If
End Function
The growing of the array could be done inline, but for clarity I use a helper function cons():
Function cons(e, a) ' default ByRef is ok; neither e nor a are changed
ReDim aTmp(UBound(a) + 1) ' create larger array
Dim i : i = 0
aTmp(i) = e ' 'new' head
For i = 1 To UBound(aTmp)
aTmp(i) = a(i - 1) ' copy 'old' elms
Next
cons = aTmp ' copy! aTmp to cons/function's return value
End Function
Calling the function is nice:
WScript.Echo 3, "[" & Join(f1("12456789"), ",") & "]"
The price to pay for avoiding the passing of 'the' array:
a lot of copies (array assingment copies in VBScript)
no tail recursion (I doubt, however, that VBScript exploits it)
about factor 10 slower than the Sub approach ((c) Bond) below
As in this case the recursive calls can/should work on the 'same' array, a Sub does the task more efficiently (and is less complex):
Sub s1(s, a) ' default ByRef is ok; a should be modified, s isn't touched
If "" <> s Then
ReDim Preserve a(UBound(a) + 1) ' grow! a
a(UBound(a)) = Left(s, 1)
s1 Mid(s, 2), a ' tail recursion for tail
End If
End Sub
Calling it looks nasty:
ReDim a(-1) : s1 "123456789", a : WScript.Echo 3, "[" & Join(a, ",") & "]"
But that can be avoided by a wrapper:
Function f2(s)
ReDim aTmp(-1)
s1 s, aTmp
f2 = aTmp
End Function

Dynamically Adding data to jagged array?

I have a recursive function that creates a list of items based on their hierarchy(integer is used to determine which level 1 to 10 max). There can be x number of items in any given level. I want to store all the items that belong the same level at the corresponding index of the jagged array. The items aren't retrieved based on their level so the level can be jumping around all of over the place as the function recurses.
Function RecurseParts(lngPartID1, lngLevel) As Object
'this function will recursivley print the parts lists for the part ID passed in
If IsNumeric(lngPartID1 & "") Then
Dim objRSTemp As Object = Server.CreateObject("ADODB.Recordset")
objRSTemp.CursorLocation = adUseClient
objRSTemp.Open(PART_LIST_SQL & lngPartID1, objConn, adOpenForwardOnly, adLockReadOnly)
'objRSTemp.ActiveConnection = Nothing
If objRSTemp.eof And objRSTemp.bof Then
'PROBLEM, WE HAVE NO RECORDS
Response.Write("There Were No Parts For This Assembly (Part ID #:" & lngPartID1 & ")")
Else
'make output
Dim strTemp As String = String.Empty
If lngLevel <> 1 Then strTemp = " style=""display: none;"">"
Response.Write("<table id='tblparts" & lngCurrentLineNum & "' border=""0"" cellspacing=""0"" width=""100%"" cellpadding=""1"" " & strTemp)
Do Until objRSTemp.EOF
'increase the current line num
lngCurrentLineNum = lngCurrentLineNum + 1
'get current Part ID
lngCurrentPartID = objRSTemp("PartID").value
'reset flag
blnIsAssm = False
'loop thru array of assemblies to see if this is a parent
For ctr = 0 To UBound(arrAssmList, 2)
If arrAssmList(0, ctr) = lngCurrentPartID Then
'the current part is an assembly
blnIsAssm = True
Exit For
ElseIf arrAssmList(0, ctr) > lngCurrentPartID Then
Exit For
End If
Next
If blnIsAssm Then
'recurse these parts
If RecurseParts(objRSTemp("PartID").value, lngLevel + 1) = True Then
'awesome
End If
End If
objRSTemp.MoveNext()
Loop
Response.Write("</table>")
End If
If objRSTemp.State Then objRSTemp.Close()
objRSTemp = Nothing
'RETURN FUNCTION
RecurseParts = True
Else
'no PART ID passed in
Response.Write("No Part ID Passed In")
RecurseParts = False
End If
End Function
It sounds like a Dictionary would work here.
Dim myDict As New Dictionary(Of Integer, List(Of String))
In your recursive function. The parts in the {} are the parts you have to supply.
'this builds the keys as you go
If Not myDict.ContainsKey({{key} -> your Integer}) Then
'add key and use the From statement to add a value if know at this time
myDict.Add({key}, New List(Of String) From {value})
Else
myDict({key}).Add({string to insert at this level})
End If
List of keys in reverse order:
Dim keys = myDict.Keys.OrderByDescending(Function(k) k)
I was able to create a List to store all the partIDs and their levels.
Dim arrSubID As New List(Of List(Of Integer))()
Function RecurseParts(paramenters)
For ctr = 0 To UBound(arrAssmList, 2)
If arrAssmList(0, ctr) = lngCurrentPartID Then
'checks whether we need a new index in the list
If lngLevel + 1 > arrSubID.Count Then
arrSubID.Add(New List(Of Integer))
End If
'adds the partID where it belongs!
arrSubID(lngLevel).Add(lngCurrentPartID)
blnIsAssm = True
Exit For
ElseIf arrAssmList(0, ctr) > lngCurrentPartID Then
Exit For
End If
Next
End Function

Adaptive a vba excel function to be recursive

Im having trouble converting a working solution that takes a directory folder as an input and outputs the filenames and other file attributes of files container in the folder into an excel spreadsheet to a recursive solution that also outputs the files contained in subfolders. I would greatly appreciate any help!
Sub GetFileList()
Dim strFolder As String
Dim varFileList As Variant
Dim FSO As Object, myFile As Object
Dim myResults As Variant
Dim l As Long
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
' Get a list of all the files in this directory. ' Note that this isn't recursive... although it could be...
varFileList = fcnGetFileList(strFolder)
If Not IsArray(varFileList) Then
MsgBox "No files found.", vbInformation
Exit Sub
End If
' Now let's get all the details for these files ' and place them into an array so it's quick to dump to XL.
ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(0, 1) = "Size"
myResults(0, 2) = "Created"
myResults(0, 3) = "Modified"
myResults(0, 4) = "Accessed"
myResults(0, 5) = "Full path"
Set FSO = CreateObject("Scripting.FileSystemObject")
' Loop through our files
For l = 0 To UBound(varFileList)
Set myFile = FSO.GetFile(CStr(varFileList(l)))
myResults(l + 1, 0) = CStr(varFileList(l))
myResults(l + 1, 1) = myFile.Size
myResults(l + 1, 2) = myFile.DateCreated
myResults(l + 1, 3) = myFile.DateLastModified
myResults(l + 1, 4) = myFile.DateLastAccessed
myResults(l + 1, 5) = myFile.Path
Next l
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set myFile = Nothing
Set FSO = Nothing
End Sub
Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant ' Returns a one dimensional array with filenames ' Otherwise returns False
Dim f As String
Dim i As Integer
Dim FileList() As String
If strFilter = "" Then strFilter = "."
Select Case Right$(strPath, 1)
Case "\", "/"
strPath = Left$(strPath, Len(strPath) - 1)
End Select
ReDim Preserve FileList(0)
f = Dir$(strPath & "\" & strFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop
If FileList(0) <> Empty Then
fcnGetFileList = FileList
Else
fcnGetFileList = False
End If
End Function
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub
I've rewritten the code to pass your results array and a counter to the recursive function. The function fills the array and calls itself with any subfolders
Sub GetFileList()
Dim strFolder As String
Dim FSO As Object
Dim fsoFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
Set fsoFolder = FSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList fsoFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set FSO = Nothing
End Sub
Private Sub FillFileList(fsoFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim fsoFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
'load the array with all the files
For Each fsoFile In fsoFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = fsoFile.Name
myResults(1, lCount) = fsoFile.Size
myResults(2, lCount) = fsoFile.DateCreated
myResults(3, lCount) = fsoFile.DateLastModified
myResults(4, lCount) = fsoFile.DateLastAccessed
myResults(5, lCount) = fsoFile.Path
Next fsoFile
'recursively call this function with any subfolders
Set fsoSubFolders = fsoFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub

Resources