frmitemnaturecard.frm

金算盘软件代码

        Case 1, 2, 3, 4, 5
            If frmAccountCard.DelCard(mlngLstID(Index), Me.hwnd) Then mlngLstID(Index) = 0
    End Select
    RefershList lstNature(Index), Index
End Sub

Private Sub lstNature_Edit(Index As Integer)
    If Index = 0 Then
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择税率再进行修改！", vbExclamation, Caption
        End If
        frmItemTax.EditCard mlngLstID(0), vbModal ', lstNature(0).Text
    Else
        If mlngLstID(Index) = 0 Then
            ShowMsg hwnd, "请先选择科目再进行修改！", vbExclamation, Caption
        End If
        frmAccountCard.EditCard mlngLstID(Index), vbModal ', lstNature(Index).Text
    End If
    RefershList lstNature(Index), Index
    If lstNature(Index).Text = "" Then mlngLstID(Index) = lstNature(Index).ID
'    lstNature(Index).TextMatrix(lstNature(Index).ReferRow, 1) = mlngListIDBuffer(Index)
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstnature_GotFocus(Index As Integer)
'    If mblnIsNew Then
'        cmdOkCancel(2).Default = False
'    Else
'        cmdOkCancel(0).Default = False
'    End If
    If lstNature(Index).Referrows <= 1 Then
        RefershList lstNature(Index), Index
    End If
End Sub

'设置列表框选项
Public Sub RefershList(lstSetting As ListText, Index As Integer)

    If Index = 0 Then
        setlistbox lstSetting, 15, mlngLstID(0)
    Else
        setlistbox lstSetting, 0, mlngLstID(Index)
    End If

End Sub

'根据列表框选择结果来调用卡片或存储调用卡片的参数
Private Sub lstnature_Choose(Index As Integer)
    If lstNature(Index).Text <> "" Then
        mlngLstID(Index) = lstNature(Index).TextMatrix(lstNature(Index).ReferRow, 1)
    Else
        mlngLstID(Index) = 0
    End If
    mblnIsChanged = True
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    
    If mblnIsExist Then Exit Sub
    Select Case Index
        Case 0
            If SaveCard Then Unload Me
        Case 1    '取消
            Unload Me
        Case 2    '下一个
            If SaveCard Then
                mblnIsNew = True
                mblnIsChanged = True
                InitCard
                txtInput.SetFocus
            End If
    End Select
End Sub

Private Function LstIsValid(ByVal blnByAdd As Boolean) As Boolean
    Dim recAcnt As rdoResultset, strSql As String

    LstIsValid = False
    If Not ItemIsValid("Tax", "lngTaxID", mlngLstID(0), , False) Then
        If Not blnByAdd Then
            ShowMsg hwnd, "税率应该是末级，您选择的“" & lstNature(0).Text _
                & "”无效，请重新选择！", vbExclamation, Caption
            lstNature(0).SetFocus
        End If
        Exit Function
    End If
    #If conVersionType = 16 Then
        If mlngLstID(1) <> 0 And Not (AccountIsValid(mlngLstID(1), 0) Or AccountIsValid(mlngLstID(1), 3) Or AccountIsValid(mlngLstID(1), 4)) Then
            If Not blnByAdd Then
                ShowMsg hwnd, "销售科目必须是没有停用的末级科目,并且科目性质不能为现金或银行，" _
                    & "您选择的“" & lstNature(1).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                lstNature(1).SetFocus
            End If
            Exit Function
        End If
        If mlngLstID(2) <> 0 And Not (AccountIsValid(mlngLstID(2), 0) Or AccountIsValid(mlngLstID(2), 3) Or AccountIsValid(mlngLstID(2), 4)) Then
            If Not blnByAdd Then
                ShowMsg hwnd, "采购科目必须是没有停用的末级科目,并且科目性质不能为现金或银行，" _
                    & "您选择的“" & lstNature(2).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                lstNature(2).SetFocus
            End If
            Exit Function
        End If
    #Else
        strSql = "SELECT * FROM Account WHERE lngAccountID=" & mlngLstID(1) _
            & " AND (blnIsInActive=1 OR blnIsDetail=0 OR blnIsQuantity=1" _
            & " OR blnIsAllCurrency=1 OR blnIsMultCurrency=1)"
        Set recAcnt = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recAcnt.EOF Then
            If Not blnByAdd Then
                ShowMsg hwnd, "收入科目必须是没有停用的末级科目,并且不能有数量核算和外币核算属性，" _
                    & "您选择的“" & lstNature(1).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                recAcnt.Close
                lstNature(1).SetFocus
            End If
            Exit Function
        End If
        strSql = "SELECT * FROM Account WHERE lngAccountID=" & mlngLstID(2) _
            & " AND (blnIsInActive=1 OR blnIsDetail=0 OR blnIsQuantity=1" _
            & " OR blnIsAllCurrency=1 OR blnIsMultCurrency=1)"
        Set recAcnt = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recAcnt.EOF Then
            If Not blnByAdd Then
                ShowMsg hwnd, "成本科目必须是没有停用的末级科目,并且不能有数量核算和外币核算属性，" _
                    & "您选择的“" & lstNature(2).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                recAcnt.Close
                lstNature(2).SetFocus
            End If
            Exit Function
        End If
        If mlngLstID(3) <> 0 And Not AccountIsValid(mlngLstID(3), 5) Then
            If Not blnByAdd Then
                ShowMsg hwnd, "存货科目必须是没有停用的末级科目,并且科目性质必须为存货，" _
                    & "您选择的“" & lstNature(3).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                lstNature(3).SetFocus
            End If
            Exit Function
        End If
        If mlngLstID(4) <> 0 And Not AccountIsValid(mlngLstID(4), 5) Then
            If Not blnByAdd Then
                ShowMsg hwnd, "差异科目必须是没有停用的末级科目,并且科目性质必须为存货，" _
                    & "您选择的“" & lstNature(4).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                lstNature(4).SetFocus
            End If
            Exit Function
        End If
        If mlngLstID(5) <> 0 And Not AccountIsValid(mlngLstID(5), 5) Then
            If Not blnByAdd Then
                ShowMsg hwnd, "待实现销项税科目必须是没有停用的末级科目,并且科目性质必须为存货，" _
                    & "您选择的“" & lstNature(5).Text & "”无效，请重新选择！", _
                    vbExclamation, Caption
                lstNature(5).SetFocus
            End If
            Exit Function
        End If
    #End If
    LstIsValid = True
End Function

'通过事务处理完成对数据库的操作
Private Function SaveCard(Optional blnByAdd As Boolean = False) As Boolean
    Dim recItemNature As rdoResultset, strSql As String
    Dim strCostMethod As String
    
    SaveCard = False
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    If mblnIsExist Then GoTo ErrHandle
    If Not mblnIsChanged Then
        SaveCard = True
        GoTo ErrHandle
    End If
    
    If Trim(txtInput.Text) = "" Then
        ShowMsg hwnd, "商品性质名称不能为空！", vbExclamation, Caption
        txtInput.SetFocus
        GoTo ErrHandle
    End If
    strSql = "SELECT * FROM ItemNature WHERE strItemNatureName='" _
        & txtInput.Text & "' AND lngItemNatureID<>" _
        & IIf(mblnIsNew, 0, mlngItemNatureID)
    Set recItemNature = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recItemNature.EOF Then
        If Not blnByAdd Then
            ShowMsg hwnd, "商品性质名称不能为重复,请重新录入！", vbExclamation, Caption
            txtInput.SetFocus
            recItemNature.Close
            txtInput.SetFocus
        End If
        GoTo ErrHandle
    Else
        recItemNature.Close
    End If
    If Not blnByAdd Then
        If cboNature(0).Text = "" Then
            ShowMsg hwnd, "商品类别不能为空！", vbExclamation, Caption
            cboNature(0).SetFocus
            GoTo ErrHandle
        End If
        If lstNature(0).Text = "" Then
            ShowMsg hwnd, "税率不能为空！", vbExclamation, Caption
            lstNature(0).SetFocus
            GoTo ErrHandle
        End If
    End If
    If Not blnByAdd Then GetLstValue
    If Not LstIsValid(blnByAdd) Then GoTo ErrHandle
    strCostMethod = cboNature(1).ListIndex + 1
    #If conVersionType = 8 Then
        If strCostMethod = 6 Then strCostMethod = 8
    #Else
        #If conVersionType = 4 Then
            strCostMethod = 2
        #End If
    #End If
    If mblnIsNew Then
'        #If conVersionType = 16 Then
'            strSql = "INSERT INTO ItemNature(strItemNatureName,strItemCategory," _
'                & "lngStockAccountID,lngSaleAccountID,lngTaxID) VALUES('" & txtInput.Text & "'," _
'                & cboNature(0).ListIndex + 1 & "," & mlngLstID(1) & "," & mlngLstID(2) & "," _
'                & mlngLstID(0) & ")"
'        #Else
        mlngItemNatureID = GetNewID("ItemNature")
            strSql = "INSERT INTO ItemNature(lngItemNatureID,strItemNatureName,strItemCategory," _
                & "lngSaleAccountID,lngCostAccountID,lngStockAccountID," _
                & "lngDiffAccountID,lngStockTaxAccountID,lngTaxID," _
                & "strCostMethod) VALUES(" & mlngItemNatureID & ",'" & Trim(txtInput.Text) & "'," _
                & cboNature(0).ListIndex + 1 & "," & mlngLstID(1) & "," & mlngLstID(2) _
                & "," & mlngLstID(3) & "," & mlngLstID(4) & "," & mlngLstID(5) & "," _
                & mlngLstID(0) & "," & strCostMethod & ")"
'        #End If
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'        strSql = "SELECT * FROM ItemNature WHERE strItemNatureName='" & Trim(txtInput.Text) & "'"
'        Set recItemNature = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'        mlngItemNatureID = recItemNature!lngItemNatureID
'        recItemNature.Close
    Else
'        #If conVersionType = 16 Then
'            strSql = "UPDATE ItemNature SET strItemNatureName='" & txtInput.Text _
'                & "',strItemCategory=" & cboNature(0).ListIndex + 1 & ",lngStockAccountID=" _
'                & mlngLstID(1) & ",lngSaleAccountID=" & mlngLstID(2) _
'                & ",lngTaxID=" & mlngLstID(0) & " WHERE lngItemNatureID=" & mlngItemNatureID
'        #Else
            strSql = "UPDATE ItemNature SET strItemNatureName='" & Trim(txtInput.Text) _
                & "',strItemCategory=" & cboNature(0).ListIndex + 1 & ",lngSaleAccountID=" _
                & mlngLstID(1) & ",lngCostAccountID=" & mlngLstID(2) & ",lngStockAccountID=" _
                & mlngLstID(3) & ",lngDiffAccountID=" & mlngLstID(4) & ",lngStockTaxAccountID=" _
                & mlngLstID(5) & ",lngTaxID=" & mlngLstID(0) & ",strCostMethod=" _
                & strCostMethod & " WHERE lngItemNatureID=" & mlngItemNatureID
'        #End If
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    mblnIsChanged = False
    SaveCard = True
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgItemNature
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function
'根据列表框输入信息来调用卡片
Private Sub lstNature_ItemNotExist(Index As Integer)

    mblnIsExist = True
    If Index = 0 Then
        If frmMsgAdd.MsgAddShow("税率不存在", "税率列表中没有“" _
            & lstNature(Index).Text & "”！") = vbCancel Then
            lstNature(Index).Text = ""
            mblnIsExist = False
            Exit Sub
        End If
    Else
        If frmMsgAdd.MsgAddShow("科目不存在", "科目列表中没有“" _
            & lstNature(Index).Text & "”！") = vbCancel Then
            lstNature(Index).Text = ""
            mblnIsExist = False
            Exit Sub
        End If
    End If
    lstNature_AddNew Index
    mblnIsExist = False
End Sub

Private Sub lstNature_LostFocus(Index As Integer)
    If Trim(lstNature(Index).Text) = "" Then mlngLstID(Index) = lstNature(Index).ID
    lstNature(Index).MoveFocus
'    BKKEY lstNature(Index).hwnd, vbKeyHome
    lstNature(Index).MoveFocus
End Sub

Private Sub GetLstValue()
    Dim i As Integer
    
    For i = 0 To 5
        If Trim(lstNature(i).Text) = "" Then mlngLstID(i) = 0
    Next i
End Sub

Private Sub txtInput_Change()
    If mblnIsInit Then Exit Sub
    If ContainErrorChar(txtInput.Text) Then BKKEY txtInput.hwnd
    mblnIsChanged = True
End Sub