frmfixedtypecard.frm

金算盘软件代码

    Dim strNextCode As String
    
    Select Case Index
        Case 0   '确定
            If SaveCard Then Unload Me
        Case 1   '取消
            Unload Me
        Case 2   '下一个
            If SaveCard Then
                strNextCode = GetNextCode(txtInput(0).Text)
'                mlngFixedTypeID = 0
                InitCard
                txtInput(0).Text = strNextCode
                txtInput(0).SetFocus
                txtInput(0).SelStart = 0
                txtInput(0).SelLength = Len(txtInput(0).Text)
            End If
        Case 3
            If SaveCard Then
                frmFixedDefineCard.TypeID = mlngFixedTypeID
                frmFixedDefineCard.Show vbModal
                Set frmFixedDefineCard = Nothing
            End If
    End Select
End Sub

Private Function MergeCode() As Boolean
    MergeCode = DisplaceActivity("FixedCard", "lngFixedTypeID", mlngPCodeID, mlngFixedTypeID)
End Function

Private Function SaveCard(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer, i As Integer   '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recFixedType As rdoResultset, strSql As String
    Dim bytLength As Byte
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtInput(0).Text) = "" Then
        ShowMsg hwnd, "固资类型编码不能为空!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    
    If InStr(1, txtInput(0).Text, mstrOldCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "固资类型不能修改为自己的下级固资类型!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrOldCode, txtInput(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "固资类型不能修改为自己的上级固资类型!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtInput(1).Text) = "" Then
        ShowMsg hwnd, "固资类型名称不能为空!", vbExclamation, Caption
        txtInput(1).SetFocus
        GoTo ErrHandle
    End If
    If optCode(1).Value Then
        If sptOrder.Value = 0 Then
            ShowMsg 0, " 自动编码的序号位数不能为0！", vbExclamation + MB_TASKMODAL, Me.Caption
            sptOrder.SetFocus
            GoTo ErrHandle
        Else
            bytLength = Len(txtInput(0).Text) + Len(txtInput(4).Text) + sptOrder.Value - stringCount(txtInput(0).Text, "-")
            If bytLength > 20 Then
                ShowMsg 0, " 固定资产类别编码+前缀+序号的总长度不应该超过20位！", vbExclamation + MB_TASKMODAL, Me.Caption
                sptOrder.SetFocus
                GoTo ErrHandle
            End If
        End If
    End If
    If cboFixedType(1).ListIndex = 5 Then
        If TxtToDouble(txtInput(5).Text) = 0 Then
            ShowMsg 0, " 折旧方法为分类折旧率时折旧率不能为零！", vbExclamation + MB_TASKMODAL, Me.Caption
            txtInput(5).SetFocus
            GoTo ErrHandle
        End If
    End If
    
    intResult = CodeCheck("FixedType", "strFixedTypeCode", "lngFixedTypeID", _
        mblnIsNew, txtInput(0).Text, txtInput(1).Text, mstrOldCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, mblnPIsInActive, _
        mblnIsDetail)
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级固资类型" _
                    & "不存在,请先增加上级固资类型”" & CodePrefix(txtInput(0).Text) & "“", _
                        vbExclamation, Caption
            End If
        Else
            ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级固资类型" _
                & "不存在,请重新修改固资类型”" _
                & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
        End If
        txtInput(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "固资类型编码“" & Trim$(txtInput(0).Text) _
                    & "”已经存在,请重新录入固资类型编码", vbExclamation, Caption
                txtInput(0).SetFocus
            End If
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or (mblnIsInActive <> mblnPIsInActive) Or Not mblnIsDetail Then
                ShowMsg hwnd, "固资类型“" & mstrOldCode & "”与固资类型“" _
                    & Trim$(txtInput(0).Text) & "”不能合并,请重新修改固资类型编码“" _
                    & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
                mlngPCodeID = 0
                txtInput(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将固资类型“" & mstrOldCode & "”与“" _
                    & Trim$(txtInput(0).Text) & "”进行合并?", vbQuestion + _
                    vbYesNo, Caption) = vbNo Then
                    txtInput(0).SetFocus
                    GoTo ErrHandle
                Else
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "固资类型编码太长,请重新修改编码!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeUsed(mlngPCodeID) Then
                If Not blnByAdd Then
                    If ShowMsg(hwnd, "固资类型“" & CodePrefix(txtInput(0).Text) & "”是一个已经发生业务的末级固资类型," _
                        & "是否在该固资类型下新增明细固资类型“" & Trim$(txtInput(0).Text) & "”," _
                        & "并将发生的所有业务转到新增的明细固资类型?", vbQuestion + vbYesNo, _
                        Caption) = vbNo Then
                        txtInput(0).SetFocus
                        GoTo ErrHandle
                    Else
                        blnMerge = True
                    End If
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
'    If CheckSameName("FixedType", "strFixedTypeCode", txtInput(0).Text, _
'        "strFixedTypeName", txtInput(1).Text, "lngFixedTypeID", _
'        IIf(mblnIsNew, 0, mlngFixedTypeID)) Then
'        If Not blnByAdd Then
'            ShowMsg hwnd, "已有同级固资类型使用了" & "“" & txtInput(1).Text & "“" & _
'                ",请重新录入固资类型名称!", vbExclamation, Caption
'            txtInput(1).SetFocus
'        End If
'        recFixedType.Close
'        GoTo ErrHandle
'    End If
    mstrCode = Trim(txtInput(0).Text)
    mstrName = Trim(txtInput(1).Text)
    mblnIsInActive = (chkPause.Value = vbChecked)
    mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    mstrDepreciationType = cboFixedType(0).ListIndex + 1
    mstrDepreciationMethod = cboFixedType(1).ListIndex + 1
    mdblNetWorthRate = TxtToDouble(txtInput(2).Text)
    If cboFixedType(1).ListIndex = 2 Then
        mdblTotalWork = TxtToDouble(txtInput(3).Text)
        mintUseAge = 0
    Else
        mdblTotalWork = 0
        mintUseAge = TxtToDouble(txtInput(3).Text)
    End If
    For i = 0 To 2
        If optCode(i).Value Then mstrCodeManner = i
    Next i
    mstrPrefix = Trim(txtInput(4).Text)
    mintOrderDec = sptOrder.Value
    mdblDeprRate = TxtToDouble(txtInput(5).Text)
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                strSql = "UPDATE FixedType SET blnIsDetail=0 WHERE " _
                    & "lngFixedTypeID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not mblnIsInActive And mblnPIsInActive And mlngPCodeID <> 0 Then
            If Not blnByAdd Then
                If ShowMsg(hwnd, "上级固资类型已经被停用,是否启用上级固资类型？", _
                    vbQuestion + vbYesNo, Caption) = vbNo Then
                    mblnIsInActive = True
                     strSql = "UPDATE FixedType SET blnIsInActive=1 WHERE " _
                        & "lngFixedTypeID=" & mlngPCodeID
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                Else
                    mblnIsInActive = False
                End If
            Else
                mblnIsInActive = False
            End If
        End If
        mlngFixedTypeID = GetNewID("FixedType")
        strSql = "INSERT INTO FixedType(lngFixedTypeID,strFixedTypeCode,strFixedTypeName," _
            & "strFullName,blnIsInActive,intLevel,blnIsDetail,strDepreciationType" _
            & ",strDepreciationMethod,dblNetWorthRate,dblTotalWork,intUseAge,strCodeManner," _
            & "strPrefix,intOrderDec,dblDeprRate,strStartDate) VALUES (" & mlngFixedTypeID & ",'" _
            & mstrCode & "','" & mstrName & "','" & mstrFullName _
            & "'," & IIf(mblnIsInActive, 1, 0) & "," & mintLevel & "," & IIf(mblnIsDetail, 1, 0) _
            & ",'" & mstrDepreciationType & "','" & mstrDepreciationMethod & "'," _
            & mdblNetWorthRate & "," & mdblTotalWork & "," & mintUseAge & ",'" _
            & IIf(mstrCodeManner = "", " ", mstrCodeManner) & "','" & IIf(mstrPrefix = "", " ", mstrPrefix) _
            & "'," & mintOrderDec & "," & mdblDeprRate & ",'" & mstrStartDate & "')"   '插入数据库
        gclsBase.BaseDB.Execute strSql
        If blnMerge Then mlngFixedTypeID = mlngPCodeID
'        If Not mblnIsInActive Then
'            strSql = "SELECT * FROM FixedType WHERE strFixedTypeCode='" & mstrCode & "'"
'            Set recFixedType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'            mlngFixedTypeID = IIf(blnMerge, mlngPCodeID, recFixedType!lngFixedTypeID)
'            recFixedType.Close
'        End If
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode Then GoTo ErrHandle
            strSql = "DELETE FROM FixedType WHERE lngFixedTypeID=" & mlngFixedTypeID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            strSql = "UPDATE FixedType SET strFixedTypeCode='" & mstrCode _
                & "',strFixedTypeName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',blnIsInActive=" & IIf(mblnIsInActive, 1, 0) & ",intLevel =" & mintLevel _
                & ",strDepreciationType='" & mstrDepreciationType & "',strDepreciationMethod='" _
                & mstrDepreciationMethod & "',dblNetWorthRate=" & mdblNetWorthRate _
                & ",dblTotalWork=" & mdblTotalWork & ",intUseAge=" & mintUseAge _
                & ",strCodeManner='" & IIf(mstrCodeManner = "", " ", mstrCodeManner) _
                & "',strPrefix='" & IIf(mstrPrefix = "", " ", mstrPrefix) _
                & "',intOrderDec=" & mintOrderDec & ",dblDeprRate=" & mdblDeprRate _
                & " WHERE lngFixedTypeID=" & mlngFixedTypeID
            gclsBase.BaseDB.Execute strSql
            If Not ChangeLowerCardCodeAndFullName("FixedType", "strFixedTypeCode", _
                "strFullName", "lngFixedTypeID", mstrOldCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("FixedType", "strFixedTypeCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                strSql = "UPDATE FixedType SET blnIsDetail=0 WHERE lngFixedTypeID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("FixedType", "strFixedTypeCode", mstrOldCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("FixedType", "strFixedTypeCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    gclsSys.SendMessage Me.hwnd, Message.msgFixed
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    If InStr(Err.Description, "违反唯一约束条件") > 0 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "已有同级固资类型使用了" & "“" & txtInput(1).Text & "“" & _
                ",请重新录入固资类型名称!", vbExclamation, Caption
            txtInput(1).SetFocus
        End If
    End If
End Function

Private Function TransActivity(ByVal lngPID As Long) As Boolean
    Dim intLevel As Integer, i As Integer
    Dim recFixedType As rdoResultset
    Dim strSql As String, strFullName As String, strCodeManner As String
    Dim dblTotalWork As Double, intUseAge As Integer
    
    strSql = "SELECT * FROM FixedType WHERE lngFixedTypeID=" & lngPID
    Set recFixedType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recFixedType
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strFixedTypeCode
    mstrName = !strFixedTypeName
    mstrDepreciationType = !strDepreciationType
    mstrDepreciationMethod = !strDepreciationMethod
    mdblNetWorthRate = !dblNetWorthRate
    mdblTotalWork = !dblTotalWork
    mintUseAge = !intUseAge
    mstrPrefix = !strPrefix
    mstrCodeManner = !strCodeManner
    mintOrderDec = !intOrderDec
    mdblDeprRate = !dblDeprRate
    strFullName = !strFullName
    End With
    recFixedType.Close
    
    If cboFixedType(1).ListIndex = 2 Then
        dblTotalWork = TxtToDouble(txtInput(3).Text)
        intUseAge = 0
    Else
        dblTotalWork = 0
        intUseAge = TxtToDouble(txtInput(3).Text)
    End If
    For i = 0 To 2
        If optCode(i).Value Then strCodeManner = i
    Next i
    intLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    strSql = "UPDATE FixedType SET strFixedTypeCode='" & Trim(txtInput(0).Text) _
        & "',strFixedTypeName='" & Trim(txtInput(1).Text) & "',strFullName='" & mstrFullName _
        & "',blnIsInActive=" & chkPause.Value & ",intLevel =" & intLevel _
        & "strDepreciationType=" & cboFixedType(0).ListIndex + 1 & ",strDepreciationMethod=" _
        & cboFixedType(1).ListIndex + 1 & ",dblNetWorthRate=" & TxtToDouble(txtInput(2).Text) _
        & ",dblTotalWork=" & dblTotalWork & ",intUseAge=" & intUseAge & ",strPrefix='" _
        & Trim(txtInput(4).Text) & "',strCodeManner='" & strCodeManner & "',intOrderDec=" _
        & sptOrder.Value & ",dblDeprRate=" & TxtToDouble(txtInput(5).Text) & ",strStartDate='" _
        & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "' WHERE lngFixedTypeID=" & lngPID
    TransActivity = gclsBase.ExecSQL(strSql)
    If TransActivity Then mstrFullName = strFullName
End Function

Private Sub optCode_Click(Index As Integer)
    If Index = 1 Then
        lblTitle(7).Enabled = True
        lblTitle(8).Enabled = True
        txtInput(4).Enabled = True
        sptOrder.Enable = True
    Else
        lblTitle(7).Enabled = False
        lblTitle(8).Enabled = False
        txtInput(4).Enabled = False
        txtInput(4).Text = ""
        sptOrder.Text = ""
        sptOrder.Enable = False
    End If
End Sub

Private Sub txtInput_Change(Index As Integer)
    
    Select Case Index
        Case 0, 4
             If ContainErrorChar(txtInput(Index).Text, "'""|?` ~!^*") Then BKKEY txtInput(Index).hwnd
        Case 1
             If ContainErrorChar(txtInput(Index).Text, "'""|?`~-!^*") Then BKKEY txtInput(Index).hwnd
        Case 2, 5
             If Not IsNum(txtInput(Index).Text, 2, True) Then BKKEY txtInput(Index).hwnd '检查输入的字符串是数字型并且是非负数
             If Val(txtInput(Index).Text) > 100 Then   '预计净残值率只能在0到100之间
                BKKEY txtInput(Index).hwnd
             End If
        Case 3
             If Not IsNum(txtInput(Index).Text, 0, True) Then BKKEY txtInput(Index).hwnd
    End Select
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
    Select Case Index
    Case 0, 4
        If InStr("'""|?`~!^ *", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Case 1
        If InStr("'""|?`~-!^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Case 2, 3, 5
        If InStr("0123456789.", Chr(KeyAscii)) = 0 And KeyAscii <> 8 Then KeyAscii = 0
    End Select
End Sub