Option Explicit
' the following are User Defined Types that define a record
' they must be declared at the beginning of a Module
Public Type DetailedFee
AverageValue As String
Fee As Currency
End Type
Public Type myRecord
Customer As String
MinimumFee As Currency
SafekeepingFee As DetailedFee
TransactionFee As DetailedFee
RepairFee As DetailedFee
End Type
Public Sub test()
ExtractData ("Path to your text file")
End Sub
'------------------------------------------------------------------
' Utility functions to help search strings
Public Function StartsWith(sourceString As String, findString As String, Optional compare As VbCompareMethod = VbCompareMethod.vbTextCompare) As Boolean
Dim lenSource As Integer
lenSource = Len(sourceString)
Dim lenFind As Integer
lenFind = Len(findString)
If Len(findString) > Len(sourceString) Then
StartsWith = False
Else
StartsWith = (InStr(1, sourceString, findString, compare) = 1)
End If
End Function ' StartsWith
Public Function Contains(sourceString As String, findString As String, positions() As Integer, Optional compare As VbCompareMethod = VbCompareMethod.vbTextCompare) As Boolean
' positions will be filled with the start position of each occurence of findString in sourceString
Dim curPos As Integer
Erase positions
Dim startPos As Integer
startPos = 1
Dim index As Integer
Dim upper As Integer
Dim searchLen As Integer
Dim findLen As Integer
searchLen = Len(sourceString)
findLen = Len(findString)
Do
curPos = InStr(startPos, sourceString, findString, compare)
If curPos <> 0 Then
ReDim Preserve positions(0 To index)
positions(index) = curPos
index = index + 1
startPos = curPos + findLen
End If
Loop Until curPos = 0 ' Or startPos > searchLen
Contains = (index > 0)
End Function ' Contains
'------------------------------------------------------------------
Private Sub ExtractData(filePath As String)
Dim fso As Object
Dim txtStream As Object
Const IOMode_ForReading As Integer = 1
Const TriState_False As Integer = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtStream = fso.OpenTextFile(filePath, IOMode_ForReading, False, TriState_False)
Dim numLines As Integer
Dim lines As New Collection
Dim page As Collection
Set page = New Collection
' create a dynamic array to store records
' in reality, you would write the values directly to a Worksheet
Dim records() As myRecord
ReDim records(0 To 9) ' initially set to 10 records, increase to whatever would be appropriate
Dim endOfPage As Boolean
Dim recordcount As Integer ' need a variable to keep track of the number of pages processed
' each page represents one record
Dim line As String ' temp line storage
Do While Not txtStream.AtEndOfStream
line = txtStream.ReadLine
'check if we reached an end of page
If Len(line) = 1 Then
If Mid$(line, 1, 1) = vbFormFeed Then endOfPage = True
End If
If Not endOfPage Then endOfPage = txtStream.AtEndOfStream
If endOfPage Then
records(recordcount) = ParsePage(page)
' make sure we have enough storage for the records, increase array storage if filled
If recordcount = UBound(records) Then
ReDim Preserve records(0 To (recordcount + 10))
End If
recordcount = recordcount + 1
' clear page collection and initialize
Set page = Nothing
Set page = New Collection
endOfPage = False ' reset flag
Else
page.Add (line)
End If
Loop
End Sub
Private Function ParsePage(page As Collection) As myRecord
Dim ret As myRecord
ret.Customer = GetCustomerName(page)
ret.MinimumFee = GetMinimumFee(page)
Dim detailBreakPoints() As Integer
Dim startofDetails As Integer
detailBreakPoints = GetDetailBreakPoints(page, startofDetails)
If startofDetails <> -1 Then ' block found
ret.SafekeepingFee = GetSafekeepingFee(page, detailBreakPoints, startofDetails)
ret.TransactionFee = GetTransactionFee(page, detailBreakPoints, startofDetails)
ret.RepairFee = GetRepairFee(page, detailBreakPoints, startofDetails)
End If
ParsePage = ret
End Function
Private Function GetCustomerName(page As Collection) As String
Dim ret As String
' the customer name is in a line with the string "Fax "
' this line is preceeded and followed by a blank line
' example:
'
'SHB INSTITUTIONAL SALES LONDON Fax nrEmail ELKE01,BOWI02
'
Dim line As String
Dim positions() As Integer
Dim i As Integer
For i = 2 To page.count - 1 ' start at line 2 because the search criteria include a blank line before the sought line
' end at 1 less than the number of lines due to a blank line must follow the sought line
If Contains(page.Item(i), "Fax ", positions) Then
' check for the preceeding and following blank lines using the length of the line
If Len(page.Item(i - 1)) = 0 And Len(page.Item(i + 1)) = 0 Then
' use the last entry in positions in case the customer name includes "Fax "
Dim lastPos As Integer
lastPos = positions(UBound(positions))
If lastPos > 1 Then
ret = trim$(Mid$(page.Item(i), 1, lastPos - 1))
Exit For
End If ' lastPos > 1
End If ' Len(page.Item(i - 1)) = 0 And Len(page.Item(i + 1)) = 0
End If 'Contains("Fax ", page.Item(i), positions)
Next i
GetCustomerName = ret
End Function
Private Function GetMinimumFee(page As Collection) As Currency
Dim ret As Currency
' the line will look like this
'Minimum fee NOK 1 1*000.00
Const NOK1 As String = "NOK 1"
Dim positions() As Integer
Dim i As Integer
For i = 1 To page.count
If StartsWith(trim$(page.Item(i)), "Minimum fee ") Then
If Contains(page.Item(i), NOK1, positions) Then
If UBound(positions) = 0 Then
Dim strNum As String
' get everything after NOK 1
strNum = Mid$(page.Item(i), positions(0) + Len(NOK1))
ret = GetCurrencyValue(strNum)
Exit For
End If ' UBound(positions) = 0
End If ' Contains(page.Item(i), NOK1, positions)
End If ' StartsWith(page.Item(i), "Minimum fee ")
Next i
GetMinimumFee = ret
End Function
Private Function GetDetailBreakPoints(page As Collection, startofDetails As Integer) As Integer()
Dim ret(0 To 1) As Integer
startofDetails = -1 ' used to signal not found
' Average value Basis point Fee
Const Average_value As String = "Average value"
Const Basis_point As String = "Basis point"
Dim positions() As Integer
Dim i As Integer
For i = 1 To page.count
If StartsWith(LTrim$(page.Item(i)), Average_value) Then
If Contains(page.Item(i), Basis_point, positions) Then
If Contains(page.Item(i), "Fee", positions) Then
ret(0) = InStr(1, page.Item(i), Average_value, vbTextCompare) + Len(Average_value)
ret(1) = InStr(1, page.Item(i), Basis_point, vbTextCompare) + Len(Basis_point)
startofDetails = i + 1
End If ' Contains(page.Item(i), "Fee", positions)
End If ' Contains(page.Item(i), "Basis point", positions)
End If ' StartsWith(page.Item(i), "Average value")
Next i
GetDetailBreakPoints = ret
End Function
Private Function GetSafekeepingFee(page As Collection, detailBreakPoints() As Integer, startofDetails As Integer) As DetailedFee
Dim ret As DetailedFee
' Average value Basis point Fee
'Safekeeping fee
' 384 196 208. (0.0070%) 2*210.44
' 2*210.44
Dim positions() As Integer
Dim i As Integer
For i = startofDetails To page.count
If LTrim$(page.Item(i)) = "Safekeeping fee" Then
If i < page.count Then
ret.AverageValue = trim$(Mid$(page.Item(i + 1), 1, detailBreakPoints(0)))
Dim strNum As String
strNum = Mid$(page.Item(i + 1), detailBreakPoints(1))
ret.Fee = GetCurrencyValue(strNum)
End If
End If ' page.Item(i) = "Safekeeping fee"
Next i
GetSafekeepingFee = ret
End Function
Private Function GetTransactionFee(page As Collection, detailBreakPoints() As Integer, startofDetails As Integer) As DetailedFee
Dim ret As DetailedFee
' Average value Basis point Fee
'Transaction fee
' #144 NOK 75. 10*800.00
' 10*800.00
Dim positions() As Integer
Dim i As Integer
For i = startofDetails To page.count
If LTrim$(page.Item(i)) = "Transaction fee" Then
If i < page.count Then
ret.AverageValue = trim$(Mid$(page.Item(i + 1), 1, detailBreakPoints(0)))
Dim strNum As String
strNum = Mid$(page.Item(i + 1), detailBreakPoints(1))
ret.Fee = GetCurrencyValue(strNum)
End If
End If ' page.Item(i) = "Transaction fee"
Next i
GetTransactionFee = ret
End Function
Private Function GetRepairFee(page As Collection, detailBreakPoints() As Integer, startofDetails As Integer) As DetailedFee
Dim ret As DetailedFee
' Average value Basis point Fee
'Transaction fee
'Repair fees #7 NOK 150. 1*050.00
' 1*050.00
Dim positions() As Integer
Dim i As Integer
For i = startofDetails To page.count
If LTrim$(page.Item(i)) = "Transaction fee" Then
If i < page.count Then
Dim line As String
line = page.Item(i + 1)
If StartsWith(LTrim$(line), "Repair fees") Then
line = Replace$(line, "Repair fees", Space$(Len("Repair fees")))
ret.AverageValue = trim$(Mid$(line, 1, detailBreakPoints(0)))
Dim strNum As String
strNum = Mid$(line, detailBreakPoints(1))
ret.Fee = GetCurrencyValue(strNum)
End If
End If
End If ' page.Item(i) = "Safekeeping fee"
Next i
GetRepairFee = ret
End Function
Private Function GetCurrencyValue(strNumber As String) As Currency ' helper function for converting string to currency
Dim tmp As String
' remove all the spaces (" ") from the string
tmp = Replace$(strNumber, " ", "")
' the values from the text file like: "1*000.00" appear to have a space in them
' however it is not a space. It has an ASCII value of 160, so need to strip that as well
' at least for the Minimum Value pages
tmp = Replace(tmp, Chr$(160), "")
GetCurrencyValue = CCur(tmp)
End Function
