I'd like to store assembly units data together with their structure in my database to be able to print assembly unit hierarchy tree traversal and to calculate assembly unit price. How can I do that?
Here is one of the possible solutions:
Option Compare Database Option Explicit '*+ ' Purpose: ' - Create sample tables representing assembly units hierarchy ' - Load sample tables with sample data ' - Calculate assembly price ' - Debug.print units hierarchy traversal tree ' ' Written by Shamil Salakhetdinov in January 1995 ' '*- Dim sSql Dim TotPrice Dim ChildPrice Dim OrdKey Sub Test() On Error GoTo ErrProc DoCmd.SetWarnings False DoCmd.RunSQL "DROP TABLE [Units Hierarchy];" DoCmd.RunSQL "DROP TABLE [Unit];" DoCmd.RunSQL "DROP TABLE [Units Traversal];" sSql = "CREATE TABLE [Units Hierarchy] ( ParentID Long, ChildId Long, " sSql = sSql & "CONSTRAINT PrimaryKey PRIMARY KEY ( ParentID, ChildID) );" DoCmd.RunSQL sSql sSql = "CREATE TABLE Unit (UnitID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " sSql = sSql & "UnitPrice CURRENCY, BaseUnitFlag BIT);" DoCmd.RunSQL sSql sSql = "CREATE TABLE [Units Traversal] (OrdNum INTEGER,Level BYTE,ParentId LONG,ChildId LONG," sSql = sSql & " Price CURRENCY,BaseUnitFlag BIT,LastFlag BIT,CONSTRAINT OrdNum PRIMARY KEY ( OrdNum))" DoCmd.RunSQL sSql DoCmd.SetWarnings True LoadUnit LoadUnitsHierarchy TotPrice = CalcAssemblyPrice(1, 0, 1) Debug.Print Debug.Print "TotPrice = "; TotPrice ' '* --- The DEBUG window printing ' ' 1 1300 [ Assembly ] ' | ' +-2 600 [ Assembly ] ' | | ' | +-3 100 * Base unit * ' | | ' | *-4 500 * Base unit * ' | ' +-5 300 * Base unit * ' | ' *-6 400 [ Assembly ] ' | ' +-7 300 [ Assembly ] ' | | ' | +-8 100 * Base unit * ' | | ' | *-9 200 * Base unit * ' | ' *-10 100 * Base unit * ' '* ' ' ' TotPrice = 1300 ' Exit Sub ErrProc: If Err <> 3376 Then Error Err End If Resume Next End Sub Function CalcAssemblyPrice(ParentID, Level, OrdNum) Dim db As Database, r As Recordset, p As Recordset, u As Recordset Dim rSql, ChildId, TotPrice As Single, BaseUnitFlag Set db = DBEngine(0)(0) Set p = db.OpenRecordset("Units Traversal", DB_OPEN_TABLE) Set u = db.OpenRecordset("Unit", DB_OPEN_TABLE) TotPrice = 0 If Level = 0 Then DoCmd.SetWarnings False DoCmd.RunSQL "Delete * from [Units Traversal];" DoCmd.SetWarnings True p.AddNew p!Level = Level p!OrdNum = OrdNum p!ParentID = 0 p!ChildId = ParentID p.Update Level = Level + 1 OrdNum = OrdNum + 1 End If rSql = "SELECT DISTINCTROW [Units Hierarchy].* FROM [Units Hierarchy] WHERE (([Units Hierarchy].ParentId=" & ParentID & "));" Set r = db.OpenRecordset(rSql) If Not r.EOF Then r.MoveFirst While Not r.EOF ChildId = r!ChildId BaseUnitFlag = False u.Index = "PrimaryKey" u.Seek "=", ChildId If u.NoMatch Then ChildPrice = 0 Else BaseUnitFlag = IIf(u!BaseUnitFlag, True, False) ChildPrice = u!UnitPrice End If r.MoveNext p.AddNew p!Level = Level p!OrdNum = OrdNum p!ParentID = ParentID p!ChildId = ChildId p!Price = 0 p!BaseUnitFlag = BaseUnitFlag p!LastFlag = IIf(r.EOF, True, False) p.Update r.MovePrevious OrdKey = OrdNum OrdNum = OrdNum + 1 ChildPrice = ChildPrice + CalcAssemblyPrice(ChildId, Level + 1, OrdNum) TotPrice = TotPrice + ChildPrice p.Index = "OrdNum" p.Seek "=", OrdKey p.Edit p!Price = ChildPrice p.Update r.MoveNext Wend End If CalcAssemblyPrice = TotPrice If Level = 1 Then p.Index = "OrdNum" p.Seek "=", 1 p.Edit p!Price = TotPrice p.Update PrintUnitsTraversal End If r.Close p.Close u.Close End Function Sub LoadUnit() Dim db As Database, u As Recordset Set db = DBEngine(0)(0) Set u = db.OpenRecordset("Unit", DB_OPEN_TABLE) LoadUnitRow u, 1, 0#, False LoadUnitRow u, 2, 0#, False LoadUnitRow u, 3, 100#, True LoadUnitRow u, 4, 500#, True LoadUnitRow u, 5, 300#, True LoadUnitRow u, 8, 100#, True LoadUnitRow u, 9, 200#, True LoadUnitRow u, 10, 100#, True u.Close End Sub Sub LoadUnitRow(u As Recordset, UnitId, UnitPrice, BaseUnitFlag) u.AddNew u!UnitId = UnitId u!UnitPrice = UnitPrice u!BaseUnitFlag = BaseUnitFlag u.Update End Sub Sub LoadUnitsHierarchy() Dim db As Database, u As Recordset Set db = DBEngine(0)(0) Set u = db.OpenRecordset("Units Hierarchy", DB_OPEN_TABLE) LoadUnitsHierarchyRow u, 1, 2 LoadUnitsHierarchyRow u, 1, 5 LoadUnitsHierarchyRow u, 1, 6 LoadUnitsHierarchyRow u, 2, 3 LoadUnitsHierarchyRow u, 2, 4 LoadUnitsHierarchyRow u, 6, 7 LoadUnitsHierarchyRow u, 6, 10 LoadUnitsHierarchyRow u, 7, 8 LoadUnitsHierarchyRow u, 7, 9 u.Close End Sub Sub LoadUnitsHierarchyRow(u As Recordset, ParentID, ChildId) u.AddNew u!ParentID = ParentID u!ChildId = ChildId u.Update End Sub Sub PrintUnitsTraversal() Dim db As Database, p As Recordset, MaxLevel, i, ll(), PrFlag Set db = DBEngine(0)(0) Set p = db.OpenRecordset("Units Traversal") MaxLevel = DMax("[Level]", "Units Traversal") ReDim ll(MaxLevel) For i = 0 To MaxLevel ll(i) = False Next i If Not p.EOF Then p.MoveFirst While Not p.EOF PrFlag = False For i = 1 To p!Level If ll(i) Then Debug.Print " "; PrFlag = True Else Debug.Print "| "; PrFlag = True End If Next i If PrFlag Then Debug.Print For i = 1 To p!Level - 1 If ll(i) Then Debug.Print " "; Else Debug.Print "| "; End If Next i If p!LastFlag Then ll(p!Level) = True Else ll(p!Level) = False End If If p!Level <> 0 Then If ll(p!Level) Then Debug.Print "*-"; Else Debug.Print "+-"; End If End If Debug.Print Trim(CStr(p!ChildId)), p!Price; If p!BaseUnitFlag Then Debug.Print "* Base unit *" Else Debug.Print "[ Assembly ]" End If If p!Level <> MaxLevel Then For i = p!Level + 1 To MaxLevel ll(i) = False Next i End If p.MoveNext Wend End If End Sub
Copyright © 1999-2008 by Shamil Salakhetdinov. All rights reserved.