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 = fs
penTextFile(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
