[AccessD] Tree shaped reports: Joe Celco BOM

Sorry I missed this thread.

I've got a couple of sample MDB's for nested tree logic.  Two are pure SQL
solutions, one from Joe and the other from a fellow expert on Expert's
Exchange.  Then I have one from a VBA standpoint, which is my own logic that
I've used for the past 20 years. I've paste the code below if anyone is
interested.

  If anyone wants copies, let me know off-list.  Note that I'm on vacation
next week.

Jim Dettman
jimdettman at earthlink.net



Public Function ExplodeBOM(strPartID As String, dblQuantity As Double) As
Integer

  Dim dbCur As Database
  Dim rstParts As Recordset
  Dim rstBOM As Recordset
  Dim rstExploded As Recordset

  Dim lngDisplayOrder As Long

  Dim intCurLevel As Integer
  Dim strParts(255) As String
  Dim lngCurLine(255) As Long
  Dim dblQPA(255) As Double

  Dim dblQtyRequired As Double
  Dim dblHoldQPA As Double
  Dim intJ As Integer

  Set dbCur = CurrentDb()
  Set rstParts = dbCur.OpenRecordset("tblPartMaster", dbOpenTable)
  rstParts.Index = "PrimaryKey"
  Set rstBOM = dbCur.OpenRecordset("tblBOM", dbOpenTable)
  rstBOM.Index = "PrimaryKey"
  Set rstExploded = dbCur.OpenRecordset("tblBOMExploded")

  ExplodeBOM = False

  ' First clear BOM explosion table.
  On Error GoTo ExplodeBOM_ErrDelete
  dbCur.Execute "DELETE * FROM tblBOMExploded", dbFailOnError
  On Error GoTo 0

  ' Find part in part master
  rstParts.Seek "=", strPartID
  If rstParts.NoMatch Then
    MsgBox "Part: " & strPartID & " cannot be found. "
    GoTo ExplodeBOM_Leave
  End If

  ' Find top level assembly, first line
  rstBOM.Seek "=", strPartID, 1
  If rstBOM.NoMatch Then
    MsgBox "Part: " & strPartID & " is not an assembly. "
    GoTo ExplodeBOM_Leave
  End If

  ' Initialize for top level
  intCurLevel = 1
  Erase strParts()
  Erase lngCurLine()
  Erase dblQPA()

  lngDisplayOrder = 0
  strParts(intCurLevel) = strPartID
  lngCurLine(intCurLevel) = 0
  dblQPA(intCurLevel) = dblQuantity

  ' Level loop
  ' Get next line from BOM.
ExplodeBOM_GetNextLine:
  lngCurLine(intCurLevel) = lngCurLine(intCurLevel) + 1
  rstBOM.Seek "=", strParts(intCurLevel), lngCurLine(intCurLevel)
  If rstBOM.NoMatch Then
    ' Go up one level
    If intCurLevel = 1 Then
      ExplodeBOM = True
      GoTo ExplodeBOM_Leave
    Else
      intCurLevel = intCurLevel - 1
      GoTo ExplodeBOM_GetNextLine
    End If
  Else
    ' Have another line. Is there a BOM for it?
    GoSub ExplodeBOM_WriteLine
    dblHoldQPA = rstBOM![QPA]
    rstBOM.Seek "=", rstBOM![PartID], 1
    If rstBOM.NoMatch Then
      ' Raw material or purchased componet
      GoTo ExplodeBOM_GetNextLine
    Else
      ' Have another assembly. Drop a Level
      intCurLevel = intCurLevel + 1
      If intCurLevel > 20 Then
        MsgBox "Explosion greater then 20 levels - Circular reference"
        GoTo ExplodeBOM_Leave
      Else
        strParts(intCurLevel) = rstBOM![AssemblyID]
        lngCurLine(intCurLevel) = 0
        dblQPA(intCurLevel) = dblHoldQPA
        GoTo ExplodeBOM_GetNextLine
      End If
    End If
  End If

ExplodeBOM_Leave:

  If Not rstExploded Is Nothing Then
    rstExploded.Close
    Set rstExploded = Nothing
  End If

  If Not rstParts Is Nothing Then
    rstParts.Close
    Set rstParts = Nothing
  End If

  If Not rstBOM Is Nothing Then
    rstBOM.Close
    Set rstBOM = Nothing
  End If

  If Not dbCur Is Nothing Then
    Set dbCur = Nothing
  End If

  Exit Function


ExplodeBOM_CalQTYReq:
  dblQtyRequired = 1
  For intJ = 1 To intCurLevel: dblQtyRequired = dblQtyRequired *
dblQPA(intJ): Next intJ
  dblQtyRequired = dblQtyRequired * rstBOM![QPA]
  Return

ExplodeBOM_WriteLine:
  GoSub ExplodeBOM_CalQTYReq
  lngDisplayOrder = lngDisplayOrder + 1
  rstExploded.AddNew
  rstExploded![DisplayOrder] = lngDisplayOrder
  rstExploded![Level] = intCurLevel
  rstExploded![Sequence] = lngCurLine(intCurLevel)
  rstExploded![PartID] = rstBOM![PartID]
  rstExploded![QtyRequired] = dblQtyRequired
  rstExploded.Update
  Return

ExplodeBOM_ErrDelete:
  MsgBox "Could not clear BOM Exploded table"
  Resume ExplodeBOM_Leave

End Function

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com]On Behalf Of Gustav Brock
Sent: Tuesday, July 15, 2003 10:45 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Tree shaped reports: Joe Celco BOM


Hi Bruce

<<snip>>