I couldn't test the copy and Kill part of the code.. I have A2000.
I used an array to hold the file names. Kinda brute force - but it should work..
the code in blue I added or changed. I modified the code so the function "StrRev" isn't needed
Code:
Option Compare Database
Option Explicit
Option Base 1 '<<--this is necessary
Option Compare Database
Option Explicit
Option Base 1
Function ImportCSVFiles()
On Error GoTo ItBroke
Const TOP_FOLDER = "C:\Imports" 'folder location of files to import
Const ARCHIVE_FOLDER = "C:\ArchivedImportedTextFiles" 'folder location of files that have been exported
Const DEST_TABLE = "tblMetImports" 'table files will be imported into
Const IMPORT_SPEC = "MetImportSpec" 'Import Specifications
Const PATH_DELIM = "\"
Dim FilesToProcess As Integer
Dim i As Integer, x As Integer
Dim bArchiveFiles As Boolean
Dim sFileName As String
Dim sOutFile As String
Dim txtFileArray() As String
Dim blDimensioned As Boolean
bArchiveFiles = True 'Reminder, set to False if you DON'T want to move imported files to new folder
blDimensioned = False
sFileName = Dir(TOP_FOLDER & "\*.csv")
Do While Len(sFileName) > 0
If blDimensioned = True Then
'Yes, so extend the array one element large than its current upper bound.
'Without the "Preserve" keyword below, the previous elements in our array
'would be erased with the resizing
ReDim Preserve txtFileArray(1 To UBound(txtFileArray) + 1) As String
Else
'No, First time through loop...so dimension it and flag it as dimensioned.
ReDim txtFileArray(1 To 1) As String
blDimensioned = True
End If
'Add the file name to the last element in the array.
txtFileArray(UBound(txtFileArray)) = TOP_FOLDER & "\" & sFileName
sFileName = Dir
Loop
' get number of files
FilesToProcess = UBound(txtFileArray)
'check that files have been located
If FilesToProcess = 0 Then
MsgBox "No files found, nothing processed", vbExclamation
Else
For i = 1 To FilesToProcess
'import each file
DoCmd.TransferText acImportDelim, IMPORT_SPEC, DEST_TABLE, txtFileArray(i), True
'archive the imported files
If bArchiveFiles Then
'code for archiving imported files...
sFileName = Mid(txtFileArray(i), InStrRev(txtFileArray(i), "\"), InStrRev(txtFileArray(i), ".") - (InStrRev(txtFileArray(i), "\")))
sOutFile = ARCHIVE_FOLDER & sFileName & "_" & Format(Date, "yyyymmdd") & ".csv"
' Debug.Print sOutFile
'not sure if the following will still work correctly
FileCopy txtFileArray(i), sOutFile
Kill txtFileArray(i)
End If
Next i
End If
Exit_ItBroke:
Exit Function
ItBroke:
If Err.Number = 9 Then 'subscript out of range
MsgBox "No files found, nothing processed", vbExclamation
Resume Exit_ItBroke
End If
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ImportMultiple"
End Function