After starting the service it loops through the timer and looks for a file in the Incoming DIR that is specified in the ini file. When one appears it processes the file:
Public Function Init() As Boolean
LocalDir = IniSettings.GetIniValue("ArchiveFileDir") 'App.Path & "\ArchivedFiles\"
If Right(LocalDir, 1) <> "\" Then
LocalDir = LocalDir & "\"
End If
' If Dir(LocalDir, vbDirectory) = "" Then
' MkDir LocalDir
' End If
FPath = IniSettings.GetIniValue("IncomingFileDir")
If Right(FPath, 1) <> "\" Then
FPath = FPath & "\"
End If
End Function
Public Sub ArchiveFile(Name As String)
On Error GoTo ErrorHandler:
Dim fso As New FileSystemObject
Dim temp As String
temp = Name & "." & Format(Date, "mmddyy") & "_" & Format(Time, "hhnnss")
logger.WriteString "Archiving File from: " & FPath & Name & " to: " & LocalDir & temp, logger.DEBUG_LOGGING
fso.MoveFile FPath & Name, LocalDir & temp & "\" '& Name.ShortName 'added &"\" to the end to try and prevent Error 53 - rds 11-4-04
'Next File 'code that was suggested to correct Error 53
Set fso = Nothing
Exit Sub
ErrorHandler:
'added select case for errors 53 and 76; rds 11-12-04
Select Case Err.Number
Case 53
logger.WriteError logger.PROD_LOGGING
Resume Next
Case 76
logger.WriteError logger.PROD_LOGGING
Resume Next
Case Else
logger.WriteError logger.PROD_LOGGING
Err.Raise 1082, "FileProcessor.ArchiveFile", "MoveFile failed."
Set fso = Nothing
End Select
End Sub
Public Function ProcessFile(FileName As String) As Boolean
On Error GoTo ErrorHandler
ResetObject
FName = FileName
UFName = "Packs" & Format(Date, "mm-dd-yy") & Format(Time, "-hh_nn") & ".dat"
Status = True
logger.WriteString "Processing File: " & FileName & " as " & UFName, logger.DEBUG_LOGGING
PurgeLocalDir
MoveFile
ParseFile
ProcessFile = True
Status = False
Exit Function
ErrorHandler:
logger.LogFatalError Err.Source, Err.Description
logger.WriteError logger.PROD_LOGGING
ProcessFile = False
Status = False
End Function
Private Sub ParseFile()
On Error GoTo ErrorHandler
logger.WriteString "Parsing file: " & FPath & FName, logger.DEBUG_LOGGING
Dim temp As String
fHandle = FreeFile()
Open LocalDir & UFName For Input As #fHandle
While Not EOF(fHandle)
Line Input #fHandle, temp
If Left(temp, 1) = "H" Then
If BatchData.TotalNumberOfRecords > 0 Then
WriteDCLinkTrans
End If
BatchData.ResetGradeData
HeaderData = Split(temp, ",")
Else
While Left(temp, 1) <> "R"
DetailData = Split(temp, ",")
If Not BatchData.AddRecord(DetailData(DGRADE), DetailData(DLENGTH), DetailData(DWIDTH), DetailData(DBOARDFEET), DetailData(DPIECES)) Then
Err.Raise 1104, "FileProcessor.ParseFile", "A failure occured while addding a detail record"
End If
Line Input #fHandle, temp
If Left(temp, 1) = "R" Then
DetailData = Split(temp, ",")
LPRNumber = DetailData(LPR)
If PrevLPRNumber = "" Then
PrevLPRNumber = LPRNumber
PrevSpecies = HeaderData(HSPECIES)
PrevThick = HeaderData(HTHICKNESS)
PrevCondition = HeaderData(HCONDITION)
PrevLayers = HeaderData(HLAYERS)
End If
If PrevLPRNumber <> LPRNumber And cacheLPRNumber <> LPRNumber Then
If REJFlag = False Then
Call CloseLPR
cacheLPRNumber = LPRNumber
PrevSpecies = HeaderData(HSPECIES)
PrevThick = HeaderData(HTHICKNESS)
PrevCondition = HeaderData(HCONDITION)
PrevLayers = HeaderData(HLAYERS)
End If
REJFlag = False
End If
End If
Wend
End If
PrevLPRNumber = LPRNumber
Wend
WriteDCLinkTrans
'WriteRejTrans
Close
BatchData.ResetGradeData
BatchData.TotalRejectAmount = 0
Exit Sub
ErrorHandler:
logger.LogFatalError Err.Source, Err.Description
Err.Raise 1082, "FileProcessor.ParseFile", "ParseFile failed."
End Sub
Private Sub MoveFile()
On Error GoTo ErrorHandler:
Dim fso As New FileSystemObject
logger.WriteString "Moving File from: " & FPath & FName & " to: " & LocalDir & UFName, logger.DEBUG_LOGGING
fso.MoveFile FPath & FName, LocalDir & UFName '& "\" '& FPath.ShortName 'added &"\" to the end to try and prevent Error 53 - rds 11-4-04
'Next File 'code that was suggested to correct Error 53
Set fso = Nothing
Exit Sub
ErrorHandler:
logger.WriteError logger.PROD_LOGGING
Err.Raise 1082, "FileProcessor.MoveFile", "MoveFile failed."
Set fso = Nothing
Resume 'added for error
End Sub
Private Sub PurgeLocalDir()
On Error GoTo ErrorHandler:
logger.WriteString "Purging Directiory: " & LocalDir, logger.DEBUG_LOGGING
Dim oFileSystem As New FileSystemObject
Dim sTemp As String
Dim FileCreateDate As Date
Dim oFolder As Folder
Dim oCurrentFile As File
Dim oFileColl As Files
Set oFolder = oFileSystem.GetFolder(LocalDir)
Set oFileColl = oFolder.Files
If oFileColl.Count > 0 Then
For Each oCurrentFile In oFileColl
FileCreateDate = oCurrentFile.DateCreated
If FileCreateDate < GetStartDate Then
logger.WriteString "Purging File: " & LocalDir & oCurrentFile.Name, logger.DEBUG_LOGGING
Kill LocalDir & oCurrentFile.Name
End If
Next
End If
CloseObjects:
Set oFileSystem = Nothing
Set oFolder = Nothing
Set oFileColl = Nothing
Set oCurrentFile = Nothing
Exit Sub
ErrorHandler:
logger.WriteError logger.PROD_LOGGING
Err.Raise 1116, "FileProcessor.PurgeLocalDir", "PurgeLocalDir failed."
Resume CloseObjects
End Sub
Private Sub ResetObject()
logger.WriteString "Resetting object after processing file: " & UFName, logger.DEBUG_LOGGING
FName = ""
UFName = ""
End Sub
Private Function GetStartDate() As Date
Dim tmp As Integer
tmp = Val(IniSettings.GetIniValue("DaysToArchieve"))
GetStartDate = DateAdd("d", -tmp, Now)
End Function
Private Function ComputerName() As String
Dim dwLen As Long
Dim strString As String
dwLen = MAX_COMPUTERNAME_LENGTH + 1
strString = String(dwLen, "X")
GetComputerName strString, dwLen
strString = Left(strString, dwLen)
ComputerName = strString
End Function
Public Function Sleeper(in_Val As Integer)
Dim icount As Integer
Do While icount < in_Val
DoEvents
icount = icount + 1
Sleep (1)
Loop
End Function
There is also some code in the app that writes a async record to our ERP system but that is very lengthy and not pertanent.
