frmwareslist.frm

针对农资系统的管理模式而开发的业务部门与财务部门的转账模式和过程

    cmdAddList.Enabled = bIsLeaf And m_bEdit
    cmdDelList.Enabled = bIsLeaf And Not bEmptyList And m_bEdit
    cmdPrintList.Enabled = Not bEmptyList
    
    With grdList
        .BackColor = IIf(bIsLeaf And m_bEdit, WHITE_COLOR, GREY_COLOR)
        .AllowAddNew = bIsLeaf And m_bEdit
        .AllowUpdate = bIsLeaf And m_bEdit
        .AllowDelete = False
        .Columns(ModeNameCol).Button = bIsLeaf And m_bEdit
    End With
End Sub

'/////////////////////////////////////////////
'//
Private Function GetParentKey(sCode As String) As String
    Dim sKey As String
    
    sKey = GetParentCode(sCode) 'Left(sCode, Len(sCode) - SERIES_LEN)
    If sKey = "" Then
        sKey = ROOT_KEY
    Else
        sKey = "K" & sKey
    End If
    
    GetParentKey = sKey
End Function

Private Sub BuildTree(sFileter As String)
    Dim TypeRs As ADODB.Recordset, sSqlStr As String
    Dim nodX As Node, sKey As String
    
    sSqlStr = "Select FWaresCode, FName From WaresList Where " & sFileter & " Order by FWaresCode"
    Set TypeRs = New ADODB.Recordset
    TypeRs.Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
    
    With TypeRs
        Do While Not .EOF
            sKey = GetParentKey(![FWaresCode])
            Set nodX = trvType.Nodes.Add(sKey, tvwChild, "K" & ![FWaresCode], ![FWaresCode] & Space(2) & ![FName])
            nodX.EnsureVisible
            .MoveNext
        Loop
    End With
    Set TypeRs = Nothing
End Sub

'/////////////////////////////////////////////
'//
Private Function GetTypeCode(sNodeKey As String) As String
    Dim sCode As String
    
    If sNodeKey = ROOT_KEY Then
        sCode = ""
    Else
        sCode = Mid(sNodeKey, 2)
    End If
    
    GetTypeCode = sCode
End Function

Private Function GetTypeName(sNodeText As String) As String
    Dim nPos As Integer, sName As String
    nPos = InStr(1, sNodeText, " ")
    If nPos = 0 Then
        sName = ""
    Else
        sName = Trim(Mid(sNodeText, nPos + 1))
    End If
    
    GetTypeName = sName
End Function

Private Function GetFullTypeName(NodeX As Node) As String
    With trvType
        If .SelectedItem Is Nothing Then
            GetFullTypeName = ""
            Exit Function
        End If
        
        Dim sText As String
        sText = ""
        Do While Not NodeX Is .Nodes(ROOT_KEY)
            sText = GetTypeName(NodeX.Text) & IIf(sText = "", "", "/") & sText
            Set NodeX = NodeX.Parent
        Loop
        GetFullTypeName = sText
    End With
End Function

'/////////////////////////////////////////////
'//
Private Sub trvType_NodeClick(ByVal Node As MSComCtlLib.Node)
    RefreshGridList (GetTypeCode(Node.Key))
End Sub

Private Sub cmdAddType_Click()
    If trvType.SelectedItem Is Nothing Then
        Exit Sub
    End If
    
    Dim f As frmEditWaresType
    Dim sParentCode As String, sCode As String, nodX As Node
    
    Set f = New frmEditWaresType
    sParentCode = GetTypeCode(trvType.SelectedItem.Key)
    f.TypeAttribute(sParentCode, GetFullTypeName(trvType.SelectedItem), "") = ""
    f.Show vbModal
    
    If f.m_bOk Then
        sCode = sParentCode & f.txtThisCode.Text
        Set nodX = trvType.Nodes.Add(trvType.SelectedItem.Key, tvwChild, "K" & sCode, sCode & Space(2) & f.txtThisName.Text)
        nodX.Selected = True
        RefreshGridList (sCode)
    End If
    Unload f
End Sub

Private Sub cmdEditType_Click()
    With trvType
        If .SelectedItem Is Nothing Or .SelectedItem = .Nodes(ROOT_KEY) Then
            Exit Sub
        End If
    End With
    
    Dim f As frmEditWaresType
    Dim sCode As String, sParentCode As String, sOldThisCode As String
    
    Set f = New frmEditWaresType
    sCode = GetTypeCode(trvType.SelectedItem.Key)
    sParentCode = GetParentCode(sCode) 'Left(sCode, Len(sCode) - SERIES_LEN)
    sOldThisCode = Right(sCode, m_gSeriesLen(GetThisSeriesNum(sCode) - 1)) 'Right(sCode, SERIES_LEN)
    f.TypeAttribute(sParentCode, GetFullTypeName(trvType.SelectedItem.Parent), sOldThisCode) = GetTypeName(trvType.SelectedItem.Text)
    f.Show vbModal
    
    If f.m_bOk Then
        sCode = sParentCode & f.txtThisCode.Text
        If f.txtThisCode.Text <> sOldThisCode Then      '代码改变
            trvType.Nodes.Remove (trvType.SelectedItem.Index)
            BuildTree ("FMaster And FWaresCode Like '" & sCode & "%'")
            
            trvType.Nodes.Item("K" & sCode).Selected = True
            RefreshGridList (sCode)
        Else                                        '名称改变
            trvType.SelectedItem.Text = sCode & Space(2) & f.txtThisName.Text
        End If
    End If
    Unload f
End Sub

'//删除条件:非根、当前分类及其下级没有明细商品
Private Sub cmdDelType_Click()
    If trvType.SelectedItem Is Nothing Then
        Exit Sub
    End If
    Dim sTempSql As String, nRet As Integer, sCode As String
    
    sCode = GetTypeCode(trvType.SelectedItem.Key)
    sTempSql = "Select Top 1 * From WaresList Where WaresList.FWaresCode Like '" & sCode & "%' And Not FMaster"
    
    If Not RsIsEmpty(sTempSql) Then
        MsgBox "该商品分类已有明细商品，不能删除！", vbInformation + vbOKOnly, "提示："
    Else
        nRet = MsgBox("您真的要删除当前商品分类吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
        If nRet = vbYes Then
            m_gDBCnn.Execute "Delete * From WaresList Where FWaresCode Like '" & sCode & "%' And FMaster"
            trvType.Nodes.Remove (trvType.SelectedItem.Index)
            RefreshGridList (GetTypeCode(trvType.SelectedItem.Key))
        End If
    End If
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

'//////////////////////////////////////////////////
'//
Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        SendKeys "{Tab}"
    End If
End Sub

Private Sub Form_Load()
    SetForm Me, 9
    Dim nodX As Node
    
    Set m_ModeRs = New ADODB.Recordset
    m_ModeRs.Open "Select * From PriceMode Order by FPriceMode", m_gDBCnn
    Set lstMode.RowSource = m_ModeRs
    lstMode.ListField = "FPriceName"
    lstMode.BoundColumn = "FPriceMode"
    
    trvType.Nodes.Clear
    Set nodX = trvType.Nodes.Add(, , ROOT_KEY, ROOT_TEXT)
    nodX.EnsureVisible
    BuildTree ("FMaster And Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'")
    
    trvType.Nodes(ROOT_KEY).Selected = True
    RefreshGridList ("")
End Sub

Private Sub Form_Resize()
    ObjectRelocate (FrameSplit.Left)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Me.MousePointer = vbDefault
End Sub

'////////////////////////////////////////////////
'//
Private Sub ObjectRelocate(nSplitLeft As Integer)
    On Error Resume Next
    
    lblTitle(0).Left = (Me.ScaleWidth - lblTitle(0).Width) / 2
    lblTitle(1).Left = lblTitle(0).Left + 30
    
    With FrameSplit
        .BorderStyle = 0
        .BackColor = GREY_COLOR
        .Left = nSplitLeft
        .Width = 80
        .Height = Me.ScaleHeight - .Top - 50
    End With
    
    With FrameType
        .Left = 50
        .Width = FrameSplit.Left - .Left
        .Height = FrameSplit.Height
        
        picTypeButtons.Top = .Height - picTypeButtons.Height - 50
        picTypeButtons.Left = (.Width - picTypeButtons.Width) / 2
    End With
    
    With FrameList
        .Left = FrameSplit.Left + FrameSplit.Width
        .Width = Me.ScaleWidth - FrameList.Left - 50
        .Height = FrameSplit.Height
        
        picListButtons.Top = .Height - picListButtons.Height - 50
        picListButtons.Left = (.Width - picListButtons.Width) / 2
    End With
    
    With trvType
        .Width = FrameType.Width - .Left - 100
        .Height = picTypeButtons.Top - .Top
    End With

    With grdList
        .Width = FrameList.Width - .Left - 100
        .Height = picListButtons.Top - .Top
    End With
End Sub

Private Sub FrameSplit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim bLeftDown As Boolean, bRightDown As Boolean
    bLeftDown = (Button And vbLeftButton) > 0
    bRightDown = (Button And vbRightButton) > 0
    
    If bRightDown Then
        FrameSplit.MousePointer = vbDefault
    ElseIf Not bLeftDown Then
        FrameSplit.MousePointer = vbSizeWE
    ElseIf FrameSplit.BackColor = BLACK_COLOR Then   '左键按下, 且处于拖动状态
        FrameSplit.Left = FrameSplit.Left + X - FrameSplit.Width / 2
    End If
End Sub

Private Sub FrameSplit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim bLeftDown As Boolean
    bLeftDown = (Button And vbLeftButton) > 0
    
    If bLeftDown Then
        FrameSplit.BackColor = BLACK_COLOR   '黑色背景色
    End If
End Sub

Private Sub FrameSplit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim bLeftDown As Boolean
    bLeftDown = (Button And vbLeftButton) > 0
    
    Dim nDivide As Integer, nLeft As Integer
    nDivide = Screen.Width / 10
    
    If bLeftDown And FrameSplit.BackColor = BLACK_COLOR Then
        nLeft = FrameSplit.Left + X - FrameSplit.Width / 2
        If nLeft < nDivide Then
            nLeft = nDivide
        ElseIf nLeft > nDivide * 7 Then
            nLeft = nDivide * 7
        End If
        ObjectRelocate (nLeft)
    End If
    
    FrameSplit.MousePointer = vbSizeWE
    FrameSplit.BackColor = GREY_COLOR     '恢复灰色背景色
End Sub

'///////////////////////////////////////////////
'//
Private Sub RefreshGridList(sCode As String)
    Dim sGrdWidth As String, sSqlStr As String
    Dim i As Integer, j As Integer
    
    If sCode = "" Then
        sSqlStr = " Where Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'"
    Else
        sSqlStr = " Where FWaresCode LIKE '" & sCode & "%'"
    End If
    m_sParentCode = sCode   'lz
    sSqlStr = "SELECT FThisCode, FWaresCode, FName, FSpecName, FMeasurement, PriceMode.FPriceName, FProducingArea, WaresList.FPriceMode, FMaster FROM WaresList Inner join PriceMode On WaresList.FPriceMode = PriceMode.FPriceMode " & sSqlStr & " And Not FMaster Order by FWaresCode"
    
    Set m_DatListRs = New ADODB.Recordset
    With m_DatListRs
        .CursorLocation = adUseClient
        .Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
        
        .Properties("Unique Table") = "WaresList"
        .Properties("Resync Command") = "SELECT * FROM (" & sSqlStr & ") WHERE FWaresCode = ?"
        .Properties("Update Resync") = adResyncAll Or adResyncUpdates Or adResyncInserts Or adResyncConflicts