本人想求购一关于ACCESS或VB处理BOM的模块

djt

Option Compare Database

Option Explicit

Dim lngNode As Long

Sub Bom(rsBom000 As ADODB.Recordset, trv As TreeView, strMat As String, Qty As Single, Level As String)

    Dim str As String

    Dim n As Integer

    Dim rsBomZi As New ADODB.Recordset

    Dim cnPhan As New ADODB.Connection

    cnPhan.Open "rovider=MSDataShape;Data Provider=NONE"

    str = _

        "SHAPE APPEND NEW adchar(30) AS ParreName," & _

            " NEW adsingle AS ParreQty," & _

            " NEW adChar(30) AS ChildName," & _

            " NEW adsingle AS ChildQty "

    If rsExpand.State = adStateOpen Then rsExpand.Close

    rsExpand.Open str, cnPhan, adOpenStatic, adLockBatchOptimistic '打开虚构记录集

     If cnn.State = adStateClosed Then Call login '打开数据库连接

   

    str = "SHAPE {select ItemName," & Qty & " as Pqty from ItemName where ItemName like '" & strMat & "' order by ItemName} APPEND"

    For n = 1 To BomLevel - 1

        str = str & " (( SHAPE {select * from BomItem} rsBom" & Format(n, "000") & " APPEND"

    Next

    str = str & " ({select * from BomItem} rsBom" & Format(n, "000")

    For n = BomLevel To 2 Step -1

        str = str & " RELATE BiItName TO BiPItName))"

    Next

    str = str & " RELATE ItemName TO BiPItName)" '数据构型 BOM

    If rsBom000.State = adStateOpen Then rsBom000.Close

   

    rsBom000.Open str, cnn, adOpenStatic, adLockBatchOptimistic '打开0层BOM

    Dim nodeItem As Node

   

    While Not rsBom000.EOF

        Select Case Level

        Case "Single Level"

            Call BomExpandNext(rsBom000, trv, 1, Qty)

        Case "Multi Level"

        

    Set nodeItem = trv.Nodes.Add(, , "a" & lngNode, rsBom000!ItemName)

    'nodeItem.EnsureVisible

            Call BomExpand(rsBom000, trv, "a" & lngNode, 1, Qty)

        End Select

        lngNode = lngNode + 1

        rsBom000.MoveNext

        nodeItem.EnsureVisible

    Wend

    'MsgBox rsExpand.RecordCount

    rsBom000.Close

End Sub

Sub BomExpand(rst As ADODB.Recordset, trv As TreeView, strKey As String, n As Integer, Qty As Single)

    Dim rstZi As New ADODB.Recordset

    Dim BomQty As Single

    Dim nodeItem As Node

    Set rstZi = rst("rsBom" & Format(n, "000")).Value

    If rstZi.RecordCount = 0 Then Exit Sub

        While Not rstZi.EOF

            'BomQty = rstZi!BiQr / rstZi!BiPr * (1 + rstZi!BiWr)

            lngNode = lngNode + 1

            Set nodeItem = trv.Nodes.Add(strKey, etvwChild, "a" & lngNode, rstZi!BiItName)

            'nodeItem.EnsureVisible

           ' nodeItem.Expanded = False

            'MsgBox rstZi!BiItName

            Call BomExpand(rstZi, trv, "a" & lngNode, n + 1, BomQty * Qty)

            'nodeItem.EnsureVisible

            rstZi.MoveNext

        Wend

               

End Sub

Sub BomExpandNext(rsBom000 As ADODB.Recordset, rsExpand As ADODB.Recordset, rst As ADODB.Recordset, n As Integer, Qty As Single)

    Dim rstZi As New ADODB.Recordset

    Dim BomQty As Single    Set rstZi = rst("rsBom" & Format(n, "000")).Value        While Not rstZi.EOF

            BomQty = rstZi!BiQr / rstZi!BiPr * (1 + rstZi!BiWr)

            'MsgBox rstZi!BiItName

            If Left(rstZi!BiItName, 1) <> "G" Then

                rsExpand.AddNew

                rsExpand!ParreName = rsBom000!ItemName

                rsExpand!ParreQty = rsBom000!Pqty

                'If n = 1 Then

                'Else

                rsExpand!ChildName = rstZi!BiItName                'Qty = Qty * BomQty

                rsExpand!ChildQty = Format(Qty * BomQty, "##.######")

                'End If

                'Exit Sub

            Else

                Call BomExpandNext(rsBom000, rsExpand, rstZi, n + 1, BomQty * Qty)            End If

            rstZi.MoveNext

        Wend

               

End Sub

Sub BomPeg(rsBom000 As ADODB.Recordset, rsExpand As ADODB.Recordset, strMat As String, Qty As Single, Level As String)

    Dim str As String

    Dim n