1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
|
Option Compare Database
Option Explicit
Public Function Import_All_IUB()
Dim sSourcePath As String
Dim sProcessedPath As String
Dim sFailedPath As String
Dim sFile As String, sNewName As String
Dim sMsg As String
Dim iResult As Integer
sSourcePath = CurrentProject.Path & "\LogsToProcess\"
sProcessedPath = CurrentProject.Path & "\LogsProcessed\"
sFailedPath = CurrentProject.Path & "\LogsFailed\"
sFile = Dir(sSourcePath & "*.log")
If Len(sFile) = 0 Then
MsgBox "No logs to process"
Else
sMsg = "Logs imported: " & vbCrLf
Do Until Len(sFile) = 0
iResult = Import_IUB_Log(sSourcePath & sFile)
sMsg = sMsg & vbCrLf & sFile
If iResult < 0 Then
sMsg = sMsg & " *** Import Failed ***"
Name sSourcePath & sFile As sFailedPath & sFile
Else
sMsg = sMsg & " (" & iResult & " records)"
sNewName = Left(sFile, Len(sFile) - 3) & Format(Date, "yymmdd") & ".log"
Name sSourcePath & sFile As sProcessedPath & sNewName
End If
sFile = Dir
Loop
MsgBox sMsg
End If
End Function
Public Function Import_IUB_Log(sFileName As String) As Integer
Dim hFile As Long
Dim sData As String
Dim sLine As String
Dim lFileLen As Long
Dim pData As Long ' pointer to current pos in data string
Dim p1 As Long, p2 As Long ' temp pointers
Dim iRecords As Integer
Dim i As Integer
Dim iLastFldPresent As Integer
Dim sRNC As String
Dim sATMPORT2 As String
Dim dtTimeStamp As Date
Dim aFields As Variant ' field names
Dim aStart(11) As Integer ' field start positions
Dim aLen(11) As Integer ' field lengths
Dim aValues(11) As String
Dim sSectors As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim fTrans As Boolean
On Error GoTo ProcErr
aFields = Array("MOD", "IUBLINK", "CELLNAMES", "CFRPHEM1", "CFRPHEM2", "CFRPHEM3", "CFRPHEM4", "CFRPHEM5", "CFRPHEM6", "ICDS", "TN", "ATMPORTS")
hFile = FreeFile
Open sFileName For Binary As #hFile
lFileLen = LOF(hFile)
sData = String(lFileLen, 0)
Get #hFile, 1, sData
Close #hFile
hFile = 0
' Find the line with "> strt"
p2 = InStr(sData, "> strt")
' find the start of the line
p1 = InStrRev(sData, vbLf, p2) + 1
' find the RNC
sRNC = Mid(sData, p1, p2 - p1)
' discard rest of that line, and the next one
pData = p2
Call GetNextLine(sData, pData)
Call GetNextLine(sData, pData)
' get next line (time stamp)
sLine = GetNextLine(sData, pData)
dtTimeStamp = DateSerial(Mid(sLine, 1, 2), Mid(sLine, 3, 2), Mid(sLine, 5, 2)) + TimeValue(Mid(sLine, 8, 8))
' Find the line with "Following xxx sites are up:"
pData = InStr(sData, " sites are up:")
' discard rest of that line, and the next one (-----...)
Call GetNextLine(sData, pData)
Call GetNextLine(sData, pData)
' get next line (field names)
sLine = GetNextLine(sData, pData)
' Find the start pos of each field in the header line
For i = 0 To 11
aStart(i) = InStr(sLine, aFields(i))
If aStart(i) <> 0 Then
If i > 0 Then
aLen(iLastFldPresent) = aStart(i) - aStart(iLastFldPresent)
End If
iLastFldPresent = i
End If
Next i
' discard next line "-------..."
Call GetNextLine(sData, pData)
' process any remaining lines where the second field starts with "Iub_"
Set db = CurrentDb
Set rs = db.OpenRecordset("IUB_Logs", dbOpenDynaset, dbAppendOnly)
BeginTrans
fTrans = True
Do While pData < lFileLen
sLine = GetNextLine(sData, pData)
If Mid(sLine, aStart(1), 4) = "Iub_" Then
For i = 0 To 10
If aStart(i) > 0 And aLen(i) > 0 Then
aValues(i) = Trim(Mid(sLine, aStart(i), aLen(i)))
End If
Next i
' put rest of line into ATMPORTS and split if necessary
aValues(11) = Trim(Mid(sLine, aStart(11)))
p1 = InStr(aValues(11), " ")
If p1 > 0 Then
sATMPORT2 = Trim(Mid(aValues(11), p1 + 1))
aValues(11) = Left(aValues(11), p1 - 1)
Else
sATMPORT2 = vbNullString
End If
' split CELLNAMES and sectors
p1 = InStr(aValues(2), "-")
If p1 > 0 Then
sSectors = Mid(aValues(2), p1 + 1)
aValues(2) = Left(aValues(2), p1 - 1)
Else
sSectors = vbNullString
End If
With rs
.AddNew
For i = 0 To 10
If Len(aValues(i)) <> 0 Then .Fields(aFields(i)) = aValues(i)
Next i
If Len(sSectors) <> 0 Then .Fields("SECTORS") = sSectors
If Len(aValues(11)) <> 0 Then .Fields("ATMPORT1") = aValues(11)
If Len(sATMPORT2) <> 0 Then .Fields("ATMPORT2") = sATMPORT2
.Fields("RNC") = sRNC
.Fields("TIMESTAMP") = dtTimeStamp
.Update
End With
iRecords = iRecords + 1
End If
Loop
CommitTrans
fTrans = False
Import_IUB_Log = iRecords
ProcEnd:
On Error Resume Next
If fTrans Then Rollback
If hFile <> 0 Then Close #hFile
If Not rs Is Nothing Then rs.Close
Exit Function
ProcErr:
Dim sErrMsg As String
If Err = 3022 Then
sErrMsg = "Duplicate data found in table"
Else
sErrMsg = Err.Description
End If
MsgBox "Failed to import " & sFileName & vbCrLf & vbCrLf & sErrMsg
Import_IUB_Log = -1 ' indicate failure
Resume ProcEnd
End Function
Private Function GetNextLine(ByRef sData As String, ByRef pStart As Long) As String
Dim pEnd As Long
pEnd = InStr(pStart, sData, vbLf)
If pEnd = 0 Then pEnd = Len(sData) + 1
GetNextLine = Mid(sData, pStart, pEnd - pStart)
pStart = pEnd + 1
End Function
|
