Parse a COBOL Copybook

basParseCopybook.bas

Option Base 0
Option Compare Database
Option Explicit
Option Private Module

'Dependency: basErrorHandler.bas
'https://gist.github.com/DataZombies/4751155

Private Type CopybookType
  ID As Long
  Complete As String
  Field As String
  Level As Long
  Array As Boolean
  Group As Boolean
  NotNull As Boolean
  Redefines As Boolean
  Format As String
  PicString As String
  GroupID As String
  RedefinesID As String
  ThisRedefines As String
  RedefinedByID As String
  Length As Long          'Field length, could be packed
  Occurrence As Long
  Position As Long
  Precision As Long       'For SQL; Maximum number of digits
  Scale_ As Long          'For SQL; Maximum number of digits to the right of the decimal point
  TotalLength As Long
End Type

Private Copybook() As CopybookType

'break string in two so the element number can be tacked on to the field name:
'Change:
'   05 Field Occurs 10 Pic XX
'Into
'   05 Field_[01] Occurs 1 Pic XX
'   05 Field_[02] Occurs 1 Pic XX
'   ...
'   05 Field_[10] Occurs 1 Pic XX
Private Sub ExpandArray(arr() As String)
  On Error GoTo ErrorHandler
  Dim intEnd As Integer, intStart As Integer
  Dim lng1 As Long, lng2 As Long, lngOccurs As Long, lngTopBound As Long
  Dim strArray As String, strField As String, strLevel As String
  Dim strOccurs As String, strTemp As String

  lngTopBound = UBound(arr)
  While lng1 <= lngTopBound
    strTemp = arr(lng1)
    If Mid$(strTemp, 7, 1) <> "*" Then
      If InStr(strTemp, " OCCURS ") Then
        strOccurs = strGetPart(strTemp, InStr(strTemp, " OCCURS ") + 8)
        lngOccurs = Val(strOccurs)
        If lngOccurs > 1 Then
          strLevel = strGetPart(strTemp, 7)
          strField = strGetPart(strTemp, InStr(7, strTemp, Format(strLevel, "00")) + 2)
          strTemp = Replace(strTemp, strField, strField & "_[]")
          
          intStart = InStr(strTemp, " OCCURS ")
          intEnd = InStr(InStr(strTemp, " OCCURS "), strTemp, strOccurs) + Len(strOccurs) - intStart
          strTemp = Replace(strTemp, Mid$(strTemp, intStart, intEnd), " OCCURS 1")
          
          ReDim Preserve arr(UBound(arr) + Val(strOccurs) - 1)
          
          For lng2 = UBound(arr) To lng1 Step -1
            If lng2 > lng1 + lngOccurs - 1 Then
              arr(lng2) = arr(lng2 - lngOccurs + 1)
            ElseIf lng2 <= lng1 + lngOccurs - 1 Then
              strArray = Format$(lng2 - lng1 + 1, String(Len(CStr(lngOccurs)), "0"))
              arr(lng2) = Replace(strTemp, "_[]", "_[" & strArray & "]")
            End If
          Next
        End If
      End If
    End If
    lngTopBound = UBound(arr)
    lng1 = lng1 + 1
  Wend
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "CheckOCCURS"
ExitHere:
End Sub

'***********************************************************************************************
' ParseCopybook (Public Sub)
'
' PARAMETERS:
'  strFilename As Sting
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Primary subroutine to import a copybook.
'  Sets .Complete, .Field & .Level
'  Uses CheckOCCURS(), CheckPIC(), CopybookRead(), CopybookWrite(),
'  FillGroupLength(), FindPosition(), FindGroupIDs() & strGetPart()
'
' USAGE:
'  ParseCopybook <Copybook Filename>, <Offset>
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Public Sub ParseCopybook(strCopybook As String)
  On Error GoTo ErrorHandler
  Dim fRedefineBlock As Boolean
  Dim lng As Long, lng2 As Long, lngRedefineLevel As Long
  Dim arr() As String

  arr = Split(strCopybook, vbNewLine)
  ExpandArray arr()
  fRedefineBlock = False
  lngRedefineLevel = 99
  ReDim Copybook(UBound(arr))
  For lng = 0 To UBound(arr)
    If Mid$(arr(lng), 7, 1) <> "*" Then
      With Copybook(lng2)
        .Level = strGetPart(arr(lng), 7)
          .Field = strGetPart(arr(lng), InStr(7, arr(lng), Format(.Level, "00")) + 2)
        If .Level <= 50 Then
          .ID = lng2
          .Complete = Trim$(arr(lng))
          .Field = strGetPart(arr(lng), InStr(7, arr(lng), Format(.Level, "00")) + 2)
          .Occurrence = 1
          CheckOCCURS Copybook(lng2)
          CheckPIC Copybook(lng2)
          CheckREDEFINES Copybook(lng2), fRedefineBlock, lngRedefineLevel
          lng2 = lng2 + 1
        End If
      End With
    End If
  Next
  ReDim Preserve Copybook(lng2 - 1)
  FindGroupIDs Copybook()
  FindGroupLengths Copybook()
  FindPosition Copybook()
  FindREDEFINES_Position Copybook()
  CopybookWrite Copybook()
  GoTo ExitHere

ErrorHandler:
  Select Case Err.Number
    Case 13
      MsgBox "Syntax error.", vbCritical, strAppName
    Case Else
      ErrorHandler "basParseCopybook", "ParseCopybook"
  End Select
ExitHere:
End Sub

'***********************************************************************************************
' CheckOCCURS (Private Sub)
'
' PARAMETERS:
'  cb As CopybookType
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the OCCURS clause and the number of iterations. Doesn't handle OCCURS...DEPENDING ON
'  Sets .Occurance, .Array and .TotalLength
'  Uses strGetPart()
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub CheckOCCURS(cb As CopybookType)
  On Error GoTo ErrorHandler

  If InStr(cb.Complete, " OCCURS ") Then
    cb.Array = True
    cb.Occurrence = strGetPart(cb.Complete, InStr(cb.Complete, " OCCURS ") + 8)
  End If
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "CheckOCCURS"
ExitHere:
End Sub

'***********************************************************************************************
' CheckPIC (Private Sub)
'
' PARAMETERS:
'  cb As CopybookType
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the PIC string.
'  Sets .Format, .Group, .Length and .TotalLength
'  Uses lngGetLength(), strGetFormat() & strGetPart()
'  Uses .Complete, .Format, .Occurance & .PicString
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub CheckPIC(cb As CopybookType)
  On Error GoTo ErrorHandler

  If InStr(cb.Complete, " PIC ") Then
    cb.PicString = strGetPart(cb.Complete, InStr(cb.Complete, " PIC ") + 5)
    cb.Format = strGetFormat(cb.Complete, cb.PicString)
    cb.Length = lngGetLength(cb.Complete, cb.Format, cb.PicString)
    cb.TotalLength = cb.Occurrence * cb.Length
  Else
    cb.Group = True
  End If
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "CheckPIC"
ExitHere:
End Sub

'***********************************************************************************************
' CheckREDEFINES (Private Sub)
'
' PARAMETERS:
'  cb As CopyBookType
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the REDEFINES stringcb.
'  Sets cb.Redefines, cb.ThisRedefines
'  Uses strReturnPart()
'  Uses cb.Complete, cb.Level, fRedefineBlock, lngRedefineLevel
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub CheckREDEFINES(cb As CopybookType, fRedefineBlock As Boolean, lngRedefineLevel As Long)
  On Error GoTo ErrorHandler
  
  If fRedefineBlock = True And lngRedefineLevel < cb.Level Then
    cb.Redefines = True
  Else
    fRedefineBlock = False
  End If
  If InStr(cb.Complete, " REDEFINES ") Then
    If fRedefineBlock = False Then lngRedefineLevel = cb.Level
    fRedefineBlock = True
    cb.Redefines = True
    cb.ThisRedefines = strGetPart(cb.Complete, InStr(cb.Complete, " REDEFINES ") + 11)
  End If
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "CheckREDEFINES"
ExitHere:
End Sub

'***********************************************************************************************
' CopybookWrite (Private Sub)
'
' PARAMETERS:
'  None
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Write the copybook to the table.
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub CopybookWrite(cb() As CopybookType)
  On Error GoTo ErrorHandler
  Dim lng As Long, lngFiller As Long

  Debug.Print ".ID;.Field;.Level;.Array;.Group;.Redefines;.GroupID;.RedefinesID;" & _
    ".RedefinedByID;.Length;.Occurrence;" & _
    ".TotalLength;.Position"
'  Debug.Print ".ID;.GroupID;.Field"
  For lng = 0 To UBound(cb)
    With cb(lng)
      If UBound(cb) > 255 Then If lng > 0 And lng Mod 190 = 0 Then Stop
      If .Field = "FILLER" Then
        lngFiller = lngFiller + 1
        .Field = .Field & lngFiller
      End If
      Debug.Print .ID; ";"; .Field; ";"; .Level; ";"; .Array; ";"; .Group; ";"; .Redefines; ";"; _
        .GroupID; ";"; .RedefinesID; ";"; .RedefinedByID; ";"; .Length; ";"; .Occurrence; ";"; _
        .TotalLength; ";"; .Position; ";"; .PicString
'      Debug.Print .ID; ";"; .GroupID; ";"; .Field
    End With
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "CopybookWrite"
ExitHere:
End Sub

'***********************************************************************************************
' FindGroupIDs (Private Sub)
'
' PARAMETERS:
'  None
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find a group's top record.
'  Uses lngGetPreviousRecord()
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub FindGroupIDs(cb() As CopybookType)
  On Error GoTo ErrorHandler
  Dim lng As Long, lngPrev As Long

  For lng = UBound(cb) To 0 Step -1
    If Not cb(lng).Redefines Then
      lngPrev = lngGetPreviousRecord(cb(), lng)
      Do While lngPrev >= 0
        If cb(lng).Level > cb(lngPrev).Level Then
          cb(lng).GroupID = cb(lngPrev).ID
          cb(lng).Redefines = cb(lngPrev).Redefines
          Exit Do
        Else
          lngPrev = lngGetPreviousRecord(cb(), lngPrev)
        End If
      Loop
    End If
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "FindGroupIDs"
ExitHere:
End Sub

'***********************************************************************************************
' FindGroupLengths (Private Sub)
'
' PARAMETERS:
'  None
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find a group's top record.
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub FindGroupLengths(cb() As CopybookType)
  On Error GoTo ErrorHandler
  Dim lng1 As Long, lng2 As Long

  For lng1 = UBound(cb) To 0 Step -1
    If Not cb(lng1).Redefines And cb(lng1).Group Then
      For lng2 = lng1 + 1 To UBound(cb)
        If Not cb(lng2).Redefines And lng1 = Val(cb(lng2).GroupID) Then
          cb(lng1).Length = cb(lng1).Length + (cb(lng2).Occurrence * cb(lng2).Length)
        End If
      Next
      cb(lng1).TotalLength = cb(lng1).Occurrence * cb(lng1).Length
    End If
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "FindGroupLengths"
ExitHere:
End Sub

'***********************************************************************************************
' FindPosition (Private Sub)
'
' PARAMETERS:
'  None
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Sets the field positions.
'  Sets .Position
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub FindPosition(cb() As CopybookType)
  On Error GoTo ErrorHandler
  Dim lng As Long, lngCurr As Long
  Dim lngNext As Long, lngStart As Long
  
  lngStart = 1
  For lng = 0 To UBound(cb)
    If cb(lng).Redefines = False Then
      If lng = 0 Or cb(lng).Position = 0 Then cb(lng).Position = lngStart
      lngStart = cb(lng).Position
      lngCurr = lng
      lngNext = lng + 1
      While lngNext <= UBound(cb)
        If cb(lngNext).Redefines = False And cb(lngNext).GroupID = cb(lng).GroupID Then
          cb(lngNext).Position = cb(lngCurr).Position + cb(lngCurr).TotalLength
          lngCurr = lngNext
        End If
        lngNext = lngNext + 1
      Wend
    End If
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "FindPosition"
ExitHere:
End Sub

'***********************************************************************************************
' FindREDEFINES_Position (Private Sub)
'
' PARAMETERS:
'  None
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find REDEFINES' position, length and total length.
'  Uses lngGetRedefined()
'  Sets .Length, .Tot_Length, .Position & .RedefinedByID
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub FindREDEFINES_Position(cb() As CopybookType)
  On Error GoTo ErrorHandler
  Dim lng As Long, lngRedefine As Long, StartPos As Long
  
  For lng = 0 To UBound(cb)
    If cb(lng).Redefines Then
      If cb(lng).ThisRedefines <> vbNullString Then
        lngRedefine = lngGetRedefined(cb(), lng, cb(lng).ThisRedefines)
        cb(lng).Length = cb(lngRedefine).Length
        cb(lng).Position = cb(lngRedefine).Position
        cb(lng).TotalLength = cb(lngRedefine).TotalLength
        StartPos = cb(lng).Position
      Else
        cb(lng).Position = StartPos
        StartPos = StartPos + (cb(lng).Length * cb(lng).Occurrence)
      End If
    End If
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "FindREDEFINES_Position"
ExitHere:
End Sub

'***********************************************************************************************
' lngGetLength (Private Function)
'
' PARAMETERS:
'  Record As CopybookType
'
' RETURN VALUE
'  Long
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the length of the field. Only used by CheckPIC().
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Function lngGetLength(ByVal strComplete As String, ByVal strFormat As String, _
                              ByVal strPic As String) As Long
  On Error GoTo ErrorHandler
  Dim intLen As Integer
  Dim strTemp As String

'Remove the decimal point
  strPic = Replace(strPic, "V", vbNullString)
'Get the length and replace it in the PIC with spaces
  While InStr(strPic, "(")
    strTemp = Mid$(strPic, InStr(strPic, "(") - 1, _
      InStr(strPic, ")") - InStr(strPic, "(") + 2)
    intLen = Mid$(strTemp, InStr(strTemp, "(") + 1, _
      InStr(strTemp, ")") - InStr(strTemp, "(") - 1)
    strPic = Replace(strPic, strTemp, String(intLen, " "))
  Wend
'The length is now strPic's length
  intLen = Len(strPic)

  Select Case strFormat
    Case "Comp", "Binary"
'Rules for Computational and Binary
      If intLen <= 4 Then
        intLen = 2
      ElseIf intLen <= 9 Then
        intLen = 4
      ElseIf intLen <= 18 Then
        intLen = 8
      End If
    Case "Comp-3", "Packed Decimal"
'Rules for Computational-3 and Packed-decimal
      intLen = Int((intLen + 1) / 2)
    Case "Numeric"
'The sign in Signed numeric is seperate
      If Left$(strPic, 1) = "S" Then intLen = intLen - 1
  End Select
'If the sign separate the length is length + 1
  If InStr(8, strComplete, " SEPARATE") Then intLen = intLen + 1
  lngGetLength = intLen
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "lngGetLength"
ExitHere:
End Function

'***********************************************************************************************
' strGetFormat (Private Function)
'
' PARAMETERS:
'  strComplete As String
'  strPic As String
'
' RETURN VALUE:
'  String
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the field's format. Only used by CheckPIC().
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Function strGetFormat(ByVal strComplete As String, ByVal strPic As String) As String
  On Error GoTo ErrorHandler
  Dim str As String

  Select Case Left$(strPic, 1)
    Case "X"
      str = "Alphanumeric"
    Case "A"
      str = "Alphabetic"
    Case Else
      str = "Numeric"
'Check for Binary
      If InStrRev(strComplete, " BINARY") Then str = "Binary"
'Check for Computational
      If InStrRev(strComplete, " COMP") Then str = "Comp"
'Check for Computational-3
      If InStrRev(strComplete, " COMP-3") Or _
      InStrRev(strComplete, " COMPUTATIONAL-3") Then str = "Comp-3"
'Check for Index
      If InStrRev(strComplete, " PACKED") Then str = "Packed Decimal"
  End Select
  strGetFormat = str
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "strGetFormat"
ExitHere:
End Function

'***********************************************************************************************
' strGetPart (Private Function)
'
' PARAMETERS:
'  str As String
'  i As Integer
'
' RETURN VALUE:
'  String
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Returns the first non-space character on or after starting position (i) up to the first
'  space character after that starting position.
'  Used by ParseCopybook(), CheckOCCURS() & CheckPIC()
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Function strGetPart(ByVal str As String, ByVal i As Integer) As String
  On Error GoTo ErrorHandler
  Dim intEnd As Integer, intStart As Integer
  
  If i > 0 Then
    Do While Mid$(str, i, 1) = " " And i < Len(str)
      i = i + 1
    Loop
    intStart = i
    i = InStr(i, str, " ")
    intEnd = IIf(i = 0, Len(str) + 1, i)
    strGetPart = Mid$(str, intStart, intEnd - intStart)
    If right$(strGetPart, 1) = "." Then _
      strGetPart = Left$(strGetPart, Len(strGetPart) - 1)
    strGetPart = Trim$(strGetPart)
  End If
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "strGetPart"
ExitHere:
End Function

'***********************************************************************************************
' lngGetPreviousRecord (Private Function)
'
' PARAMETERS:
'  lng As Long
'
' RETURN VALUE:
'  Long
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Find the previous group field. Only used by FindGroupIDs().
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Function lngGetPreviousRecord(cb() As CopybookType, ByVal lng As Long) As Long
  On Error GoTo ErrorHandler

  If lng = 0 Then
    lngGetPreviousRecord = -1
  Else
    For lngGetPreviousRecord = lng - 1 To 0 Step -1
      If Not cb(lngGetPreviousRecord).Redefines Then
        Exit For
      End If
    Next
  End If
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "lngGetPreviousRecord", "lng: " & lng
ExitHere:
End Function

'***********************************************************************************************
' lngGetRedefined (Private Function)
'
' PARAMETERS:
'  lngR As Long
'  ThisRedefines As String
'
' RETURN VALUE:
'  Long
'
' DEPENDENCIES:
'  ErrorHandler
'
' DESCRIPTION:
'  Sets the field positions. Only used by FillRedefines().
'
' MODIFICATION HISTORY:
' March 2007
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Function lngGetRedefined(cb() As CopybookType, ByVal lngR As Long, _
                                      ByVal ThisRedefines As String) As Long
  On Error GoTo ErrorHandler
  
  For lngGetRedefined = lngR - 1 To 0 Step -1
    If cb(lngGetRedefined).Field = ThisRedefines Then
      If cb(lngGetRedefined).RedefinedByID <> vbNullString Then
        cb(lngGetRedefined).RedefinedByID = cb(lngGetRedefined).RedefinedByID & "~"
      End If
      cb(lngGetRedefined).RedefinedByID = cb(lngGetRedefined).RedefinedByID & cb(lngR).ID
      cb(lngR).RedefinesID = cb(lngGetRedefined).ID
      Exit For
    End If
  Next
  GoTo ExitHere

ErrorHandler:
  ErrorHandler "basParseCopybook", "lngGetRedefined", "lngR: " & lngR & vbNewLine & _
    "ThisRedefines: " & ThisRedefines
ExitHere:
End Function