Bob
This code will do it.
Set the reference to Microsoft Scripting Runtime
(as described in the function "ChangeFileNames").
Incidentally, you could open a dialog to allow the
user to select a folder, but you'd need some tricky
code.
Good luck
Geoff
*** CODE START ***
' In general declarations at top of module:
' Change constant to FALSE if using Access 97:
Const UsingAccess2000_OrLater As Boolean = True
Private Sub Command11_Click()
Dim myfile
Dim mypath
Dim InputMsg As String
Dim InputTblName As String
Dim mytable
On Error GoTo ErrorHandler
' Get folder from user:
InputMsg = "Type the path of the folder that " _
& "contains the files you want " _
& "to import."
mypath = InputBox(InputMsg)
' Get table name from user:
InputTblName = "Type the name of the table " _
& "you want to create."
mytable = InputBox(InputTblName)
' Change all files ending in ".XLS" in the
' folder "mypath" to filenames ending in ".TXT":
If Not ChangeFileNames(mypath) Then GoTo Bye
myfile = Dir(mypath & "*.txt")
Do While myfile <> ""
' This will import ALL the excel files (one at
' a time, but automatically) in this folder.'
DoCmd.TransferText acImportDelim, _
"Tab_Spec", mytable, mypath & myfile
myfile = Dir
Loop
Bye:
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbOKOnly, _
"Error Number: " & Err.Number
Resume Bye
End Sub
Function ChangeFileNames(ByVal strPath As String) As Boolean
' For files in the folder defined by the variable strPath,
' remove periods from all filenames ending in ".XLS"
' and rename them with a ".TXT" filename extension.
' Uses Microsoft Scripting Runtime.
' To set a reference to Microsoft Scripting Runtime:
' In the VBA editor, open the TOOLS menu and
' click References. In the References dialog,
' check Microsoft Scripting Runtime.
' Out:
' Returns FALSE if path does not exist.
Dim objFSO As Scripting.FileSystemObject
Dim objFLDR As Scripting.Folder
Dim objFILES As Scripting.Files
Dim objFILE As Scripting.File
Dim strNewFileName As String
Dim strNewPathName As String
Dim strMessage As String
Dim intOptions As Integer
Dim strHeading As String
Const conDblLine As String = vbNewLine & vbNewLine
On Error GoTo ErrorHandler
' Set FALSE return:
ChangeFileNames = False
' Initialise:
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check folder exists:
If Not objFSO.FolderExists(strPath) Then GoTo FolderDoesNotExist
' Initialise:
Set objFLDR = objFSO.GetFolder(strPath)
Set objFILES = objFLDR.Files
' Loop through all files in folder and rename XLS files:
For Each objFILE In objFILES
GoSub PrepareToRenameFile
Next
' Set TRUE return:
ChangeFileNames = True
Bye:
Set objFILE = Nothing
Set objFILES = Nothing
Set objFLDR = Nothing
Set objFSO = Nothing
Exit Function
FolderDoesNotExist:
MsgBox strPath & vbNewLine _
& "The above path does not exist.", vbOKOnly, "Invalid Path"
GoTo Bye
PrepareToRenameFile:
If Not UCase(Right(objFILE.Name, 4)) = ".XLS" Then Return
strNewFileName = GetNewFileName(objFILE.Name)
strNewPathName = strPath & "\" & strNewFileName
If objFSO.FileExists(strNewPathName) Then GoTo Q_ReplaceFile
GoTo RenameOldFile
Q_ReplaceFile:
strMessage = strNewPathName & vbNewLine _
& "The above file already exists." & conDblLine _
& "Overwrite old file with new?"
intOptions = vbExclamation + vbYesNoCancel
strHeading = "File Exists"
Select Case MsgBox(strMessage, intOptions, strHeading)
Case vbYes
objFSO.DeleteFile strNewPathName
GoTo RenameOldFile
Case vbNo
Return
Case Else
GoTo Bye
End Select
RenameOldFile:
objFILE.Name = strNewFileName
Return
ErrorHandler:
MsgBox Err.Description, , "Error Number: " & Err.Number
Resume Bye
End Function
Function GetNewFileName(ByVal strOldFileName As String) As String
' Out:
' Return new filename without periods and with ".txt" filename
extension.
Dim strNewName As String
Dim strTemp() As String
Dim I As Integer
Dim lngStart As Long
Dim lngEnd As Long
#If UsingAccess2000_OrLater Then
' Use the Split function in Access 2000 or later.
strTemp = Split(strOldFileName, ".")
#Else
' Use the InStr function in Access 97.
' Initialise:
lngStart = 1
I = -1
' Get first period position:
lngEnd = InStr(lngStart, strOldFileName, ".")
' Loop through filename until no more periods:
Do Until lngEnd = 0
I = I + 1
ReDim Preserve strTemp(I)
strTemp(I) = Mid(strOldFileName, lngStart, lngEnd - lngStart)
lngStart = lngEnd + 1
lngEnd = InStr(lngStart, strOldFileName, ".")
Loop
' Put characters after last period into array:
I = I + 1
ReDim Preserve strTemp(I)
strTemp(I) = Mid(strOldFileName, lngStart)
#End If
' Put name back together again without periods:
For I = LBound(strTemp) To UBound(strTemp)
strNewName = strNewName & strTemp(I)
Next
' Remove "xls" and add ".txt"
strNewName = Left(strNewName, Len(strNewName) - 3) & ".txt"
' Return new file name:
GetNewFileName = strNewName
End Function
*** CODE END ***
