Option Compare Database
Option Explicit

Public Function rf_test()
    Dim strFilePath As String
    
    strFilePath = "c:\!!\in.txt"
    ShFileRead strFilePath
End Function

Public Function ShFileRead(ByVal vstrFilePath As String)
    Dim intFn As Integer
    Dim strFilePath As String
    Dim strBuf As String
    Dim intPos As Integer
    Dim blnDataBlockStartLine As Boolean
    Dim blnDataBlockReadInProgress As Boolean
    Dim blnAttrNamesCollected As Boolean
    
    Dim colRows As New Collection
    Dim colAttrNames As New Collection
    Dim colRow As Collection
    Dim strCurrName As String
    
    strFilePath = vstrFilePath
    intFn = FreeFile
    
    Open strFilePath For Input As #intFn
    
    While Not EOF(intFn)
        Line Input #intFn, strBuf
        
        strBuf = Trim(strBuf)
        If Len(strBuf) <> 0 Then
           intPos = InStr(1, strBuf, ":")
           If intPos = 0 Then
              blnDataBlockStartLine = True
           End If
           
           If blnDataBlockStartLine And blnDataBlockReadInProgress Then
              GoSub NewRowProcess
              DebugPrint "*** end ***"
              blnDataBlockReadInProgress = False
              blnAttrNamesCollected = True
           End If
           
           If blnDataBlockStartLine Then
              DebugPrint "*** Start ***"
              blnDataBlockStartLine = False
              blnDataBlockReadInProgress = True
              strCurrName = strBuf
              Set colRow = New Collection
              colRow.Add strBuf, "Name"
              If blnAttrNamesCollected = False Then
                 colAttrNames.Add "Name", "Name"
              End If
           ElseIf blnDataBlockReadInProgress Then
              CurrLineParse strBuf, colRow, colAttrNames, blnAttrNamesCollected
           End If
           
           DebugPrint strBuf
        End If
    Wend
    
    If blnDataBlockReadInProgress Then
       GoSub NewRowProcess
       DebugPrint "*** end ***"
       blnDataBlockReadInProgress = False
    End If

    Close #intFn
    
    RowsEnum colAttrNames, colRows
    
    Set colAttrNames = Nothing
    Set colRow = Nothing
    Set colRows = Nothing
    
    Exit Function
    
NewRowProcess:
    colRows.Add colRow, strCurrName
    Return
End Function

Private Function DebugPrint(Optional ByVal vstrMsg As String = "", _
                            Optional ByVal vblnPrint As Boolean = False)
    If vblnPrint Then
       Debug.Print vstrMsg
    End If
End Function

Private Function CurrLineParse(ByVal vstrBuf As String, _
                               ByRef rcolRow As Collection, _
                               ByRef rcolAttrNames As Collection, _
                               ByVal vblnAttrNamesCollected As Boolean)
                               
    Dim intPos As Integer
    Dim strTmpBuf As String
    Dim strAttrName As String
    Dim strAttrValue As String
    Dim i As Integer
    Dim strCurrChar As String * 1
    Dim strPrevChar As String * 1
    
    strTmpBuf = vstrBuf
    
    intPos = InStr(1, strTmpBuf, ":")
    While intPos
        If Not IsNumeric(Mid(strTmpBuf, intPos - 1, 1)) Then
          ' parse attribute
          strAttrName = Left(strTmpBuf, intPos - 1)
          strAttrValue = ""
          strPrevChar = ""
          strCurrChar = ""
          For i = intPos + 1 To Len(strTmpBuf)
            strCurrChar = Mid(strTmpBuf, i, 1)
            If IsNumeric(strCurrChar) Or _
               strCurrChar = ":" And IsNumeric(strPrevChar) Or _
               strCurrChar = " " Or _
               strCurrChar = "/" Or _
               strCurrChar = "$" Or _
               strCurrChar = "." Or _
               strCurrChar = Chr(9) Then
               
               strAttrValue = strAttrValue & strCurrChar
               strPrevChar = strCurrChar
            Else
               GoSub CurrAttrAdd
               Exit For
            End If
          Next
        Else
          ' skip time
          strTmpBuf = Mid(strTmpBuf, intPos + 1)
        End If
        
        If strAttrName <> "" Then
           GoSub CurrAttrAdd
        End If
        intPos = InStr(1, strTmpBuf, ":")
    Wend
    
    If strAttrName <> "" Then
        GoSub CurrAttrAdd
    End If
    
    Exit Function
    
CurrAttrAdd:
    If vblnAttrNamesCollected = False Then
       rcolAttrNames.Add strAttrName, strAttrName
    End If
    
    rcolRow.Add Trim(strAttrValue), strAttrName
    strTmpBuf = Trim(Mid(strTmpBuf, i))
    intPos = 1
    strAttrName = ""
    strAttrValue = ""
    Return
End Function

Private Function RowsEnum(ByRef rcolAttrNames As Collection, _
                          ByRef rcolRows As Collection)
                          
    Dim col As Collection
    Dim lngCnt As Long
    Dim i As Integer
    Dim strAttrName As String
    
    If rcolRows.Count > 0 Then
       For Each col In rcolRows
          lngCnt = lngCnt + 1
          DebugPrint , True
          DebugPrint "Row #" & CStr(lngCnt), True
          For i = 1 To rcolAttrNames.Count
             strAttrName = rcolAttrNames(i)
             DebugPrint "   " & strAttrName & " = " & col(strAttrName), True
          Next
       Next
    End If
End Function