Error message when trying to import 6 text files

[jj1972abc]

I am getting an error message when l try to import 6 files into Access, it is:

ParseandDigest file routine
Error: 53 - files not found.

If you require a screenshot and/or of copy of databaseso you can get a better understanding of the error please let me know.

Any help would be appreciated.

 

[jj1972abc]

This is the coding, l could not find a way to attach a file.

Option Compare Database
Option Explicit

Private sFiles() As String
Private sUniqueParts() As String
Private sDuplicateParts() As String
Private iFileIndex As Integer
Private lUPIndex As Long
Private lDPIndex As Long

Private Const LEFT_REQ_LEN As Integer = 5
Private Const RIGHT_REQ_LEN As Integer = 8
Private Const FIELD_DELIM As String = "."
Private Const REQ_VTS_LEN As Integer = 8
Private Sub cmdImportVTSFiles_Click()
On Error GoTo Err_cmdImportVTSFiles_Click

With Me
If VBA.Len(Nz(.cboFileType, "")) Then
If .lstFilesToImport.ListIndex > -1 Then
Call GatherFiles
Call ProcessFiles
Call DumpArraysToDataTables
MsgBox "Import procedure complete"
Else
MsgBox "Kindly select at least one file to import."
End If
Else
MsgBox "Kindly select an import file type."
End If
End With

Exit_cmdImportVTSFiles_Click:
Exit Sub

Err_cmdImportVTSFiles_Click:
Call ErrHandler("cmdImportVTSFiles_Click event within " & Me.Name, Err.Number, Err.Description)
Resume Exit_cmdImportVTSFiles_Click

End Sub

Private Sub GatherFiles()
On Error GoTo Err_GatherFiles

Dim i As Long

With Me.lstFilesToImport
For i = 0 To .ListCount
If .Selected(i) Then
iFileIndex = iFileIndex + 1
ReDim Preserve sFiles(iFileIndex)
sFiles(iFileIndex) = Me.txtFileLocation & .ItemData(i)
End If
Next i
End With

Exit_GatherFiles:
Exit Sub

Err_GatherFiles:
Call ErrHandler("GatherFiles routine", Err.Number, Err.Description)
Resume Exit_GatherFiles

End Sub

Private Sub VerifyFileExists(ByVal sFileName As String)
On Error GoTo Err_VerifyFileExists

Dim fso As New FileSystemObject

If fso.FileExists(sFileName) Then
iFileIndex = iFileIndex + 1
ReDim Preserve sFiles(iFileIndex)
sFiles(iFileIndex) = sFileName
End If

Exit_VerifyFileExists:
Exit Sub

Err_VerifyFileExists:
Call ErrHandler("VerifyFileExists routine", Err.Number, Err.Description)
Resume Exit_VerifyFileExists

End Sub

Private Sub ProcessFiles()
On Error GoTo Err_ProcessFiles

Dim i As Integer

'Traverse the array of sFiles
'For each file,
' -- open the text file
' -- gather each part number
' -- if it is already in the sUniqueParts() array
' add the part to sDuplicateParts() array
' else
' add the part to sUniqueParts() array
For i = 1 To iFileIndex
Call ParseAndDigestFile(sFiles(i))
Next i

Exit_ProcessFiles:
Exit Sub

Err_ProcessFiles:
Call ErrHandler("ProcessFiles routine", Err.Number, Err.Description)
Resume Exit_ProcessFiles

End Sub

Private Sub ParseAndDigestFile(ByVal sFileName As String)
On Error GoTo Err_ParseAndDigestFile

Dim fso As New FileSystemObject
Dim t As TextStream
Dim sBuffer As String, sPart As String

Set t = fspenTextFile(FileName:=sFileName, IOMode:=ForReading)

With t
While Not .AtEndOfStream
sBuffer = .ReadLine
If IsLegalPart(sBuffer, sPart) Then
If AlreadyInUniqueParts(sPart) Then
Call AddToArray(sPart, "Duplicate")
Else
Call AddToArray(sPart, "Unique")
End If
End If
Wend
End With

Exit_ParseAndDigestFile:
Exit Sub

Err_ParseAndDigestFile:
Call ErrHandler("ParseAndDigestFile routine", Err.Number, Err.Description)
Resume Exit_ParseAndDigestFile

End Sub

Private Function AlreadyInUniqueParts(ByVal sPart As String) As Boolean
On Error GoTo Err_AlreadyInUniqueParts

Dim bResult As Boolean
Dim i As Long

bResult = False

For i = 1 To lUPIndex
If sUniqueParts(i) = sPart Then
bResult = True
Exit For
End If
Next i

Exit_AlreadyInUniqueParts:
AlreadyInUniqueParts = bResult
Exit Function

Err_AlreadyInUniqueParts:
Call ErrHandler("AlreadyInUniqueParts function", Err.Number, Err.Description)
Resume Exit_AlreadyInUniqueParts

End Function

Private Sub AddToArray(ByVal sPart As String, ByVal sArrayType As String)
On Error GoTo Err_AddToArray

If sArrayType = "Unique" Then
lUPIndex = lUPIndex + 1
ReDim Preserve sUniqueParts(lUPIndex)
sUniqueParts(lUPIndex) = sPart
Else
lDPIndex = lDPIndex + 1
ReDim Preserve sDuplicateParts(lDPIndex)
sDuplicateParts(lDPIndex) = sPart
End If

Exit_AddToArray:
Exit Sub

Err_AddToArray:
Call ErrHandler("AddToArray routine", Err.Number, Err.Description)
Resume Exit_AddToArray

End Sub

Private Function IsLegalPart(ByVal sInput As String, _
ByRef sPart As String) As Boolean
On Error GoTo Err_IsLegalPart

Dim bResult As Boolean
Dim sTemp As String
Dim iPos As Integer, iSecondSpace As Integer, iLengthOfPart As Integer

bResult = False

With Me
iLengthOfPart = VBA.Len(sInput)
If iLengthOfPart Then
Select Case Nz(.cboFileType, "")
Case "ivpn"
iPos = VBA.InStr(sPart, FIELD_DELIM)
If iPos = LEFT_REQ_LEN + 1 Then
If iLengthOfPart - iPos = RIGHT_REQ_LEN Then
bResult = True
sPart = sInput
End If
End If
Case "vts"
iPos = VBA.InStr(sInput, " ")
iSecondSpace = VBA.InStr(iPos, sInput, " ")
'There better be 8 characters between iSecondSpace and iPos
' or there is trouble in River City
If (iSecondSpace - 1) = REQ_VTS_LEN Then
sPart = VBA.Left(sInput, iPos + iSecondSpace - 1)
bResult = True
End If
Case Else 'Ignore the part, we don't know how to process it
End Select
End If
End With

Exit_IsLegalPart:
IsLegalPart = bResult
Exit Function

Err_IsLegalPart:
Call ErrHandler("IsLegalPart function", Err.Number, Err.Description)
Resume Exit_IsLegalPart

End Function

Private Sub DumpArraysToDataTables()
On Error GoTo Err_DumpArraysToDataTables

Dim sDest As String, sSQL As String
Dim MyRS As DAO.Recordset
Dim i As Long

sDest = "tbl_" & Me.cboFileType & "_UniqueParts"
sSQL = "DELETE " & sDest & ".* FROM " & sDest & ";"
CurrentDb.Execute sSQL

Set MyRS = CurrentDb.OpenRecordset(sDest)
For i = 1 To lUPIndex
With MyRS
.AddNew
.Fields("PartNumber").Value = sUniqueParts(i)
.Update
End With
Next i
MyRS.Close

sDest = "tbl_" & Me.cboFileType & "_DuplicatedParts"
sSQL = "DELETE " & sDest & ".* FROM " & sDest & ";"
CurrentDb.Execute sSQL

Set MyRS = CurrentDb.OpenRecordset(sDest)
For i = 1 To lDPIndex
With MyRS
.AddNew
.Fields("PartNumber").Value = sDuplicateParts(i)
.Update
End With
Next i
MyRS.Close

Exit_DumpArraysToDataTables:
Set MyRS = Nothing
Exit Sub

Err_DumpArraysToDataTables:
Call ErrHandler("DumpArraysToDataTables routine", Err.Number, Err.Description)
Resume Exit_DumpArraysToDataTables

End Sub

Private Sub Form_Load()
On Error GoTo Err_Form_Load

'Look in D:\Access stuff for txt files
Me.txtFileLocation = "D:\Access stuff\"
Call LoadListWithTextFiles

Exit_Form_Load:
Exit Sub

Err_Form_Load:
Call ErrHandler("Form_Load event within " & Me.Name, Err.Number, Err.Description)
Resume Exit_Form_Load

End Sub

Private Sub txtFileLocation_AfterUpdate()
On Error GoTo Err_txtFileLocation_AfterUpdate

Call LoadListWithTextFiles

Exit_txtFileLocation_AfterUpdate:
Exit Sub

Err_txtFileLocation_AfterUpdate:
Call ErrHandler("txtFileLocation_AfterUpdate event within " & Me.Name, Err.Number, Err.Description)
Resume Exit_txtFileLocation_AfterUpdate

End Sub



Private Sub LoadListWithTextFiles()
On Error GoTo Err_LoadListWithTextFiles

Dim sFileNames As String

With Me
sFileNames = GetTextFiles(Nz(.txtFileLocation, ""))
.lstFilesToImport.RowSource = sFileNames
End With

Exit_LoadListWithTextFiles:
Exit Sub

Err_LoadListWithTextFiles:
Call ErrHandler("LoadListWithTextFiles routine", Err.Number, Err.Description)
Resume Exit_LoadListWithTextFiles

End Sub

Private Function GetTextFiles(ByVal sDirectory As String) As String
On Error GoTo Err_GetTextFiles

Dim sResult As String, sFile As String
Dim fso As New FileSystemObject

If fso.FolderExists(sDirectory) Then
sFile = VBA.Dir(sDirectory & "*.txt")
While VBA.Len(sFile)
sResult = sResult & sFile & ";"
sFile = VBA.Dir
Wend
End If

If VBA.Right(sResult, 1) = ";" Then sResult = VBA.Left(sResult, VBA.Len(sResult) - 1)

Exit_GetTextFiles:
GetTextFiles = sResult
Exit Function

Err_GetTextFiles:
Call ErrHandler("GetTextFiles function", Err.Number, Err.Description)
Resume Exit_GetTextFiles

End Function