frmfixedtypelistcard.frm

金算盘软件代码

'                        SetBuffer "UPDATE FixedType SET strFixedTypeCode='" & .strFixedTypeCode _
'                            & "',strFixedTypeName='" & .strFixedTypeName & "',strFullName='" _
'                            & .strFullName & "',blnIsInActive=" & .blnIsInActive _
'                            & ",intLevel =" & .intLevel & ",blnIsDetail=True" _
'                            & ",strDepreciationType ='" & .strDepreciationType _
'                            & "',strDepreciationMethod='" & .strDepreciationMethod _
'                            & "',dblNetWorthRate =" & .dblNetWorthRate & ",dblTotalWork=" _
'                            & .dblTotalWork & ",intUseAge=" & .intUseAge _
'                            & " WHERE lngFixedTypeID=" & .lngFixedTypeID   '修改数据库
                        recSelect.Close
                        Exit Function '合并成功
                    Else '不想合并
                        validityCheck = False
                        InputAgain
                        recSelect.Close
                        Exit Function
                    End If
                End If
            Else '编码唯一
                If .intLevel > 1 And CodePrefix(.strFixedTypeCode) <> _
                    CodePrefix(txtInput(0).Text) Then
                    UpdateOldParent .strFixedTypeCode  '改变原上级编码的末级属性
                End If
                .intLevel = strCount(txtInput(0).Text, "-") + 1 '新编码的层次
                If .intLevel > 1 Then
                    strNewFullName = UpdateNewParent(txtInput(0).Text, .blnIsDetail)
                    If strNewFullName = "" Then
                        validityCheck = False
                        InputAgain
                        recSelect.Close
                        Exit Function
                    End If
                End If
                If strNewFullName = "" Then
                    .strFullName = txtInput(1).Text
                Else
                    .strFullName = strNewFullName
                End If
                If Not .blnIsDetail Then
                    If Not UpdateChild(txtInput(0).Text, .strFixedTypeCode, .strFullName) Then   '修改原下级编码
                        validityCheck = False
                        InputAgain
                        recSelect.Close
                        Exit Function
                    End If
                End If
                SettingRecord '整理记录
                If mblnAddRecord Then
                    SetBuffer "INSERT INTO FixedType( strFixedTypeCode,strFixedTypeName," _
                        & "strFullName,blnIsInActive,intLevel,blnIsDetail,strDepreciationType" _
                        & ",strDepreciationMethod,dblNetWorthRate,dblTotalWork,intUseAge,strStartDate)" _
                        & " VALUES ( '" _
                        & .strFixedTypeCode & "','" & .strFixedTypeName & "','" & .strFullName _
                        & "'," & IIf(.blnIsInActive, 1, 0) & "," & .intLevel & "," & IIf(.blnIsDetail, 1, 0) _
                        & ",'" & .strDepreciationType & "','" & .strDepreciationMethod & "'," _
                        & .dblNetWorthRate & "," & .dblTotalWork & "," & .intUseAge & ",'" & Format(gclsBase.BaseDate, "yyyy-mm-dd") & "')"
                Else
                    SetBuffer "UPDATE FixedType SET strFixedTypeCode='" & .strFixedTypeCode _
                        & "',strFixedTypeName='" & .strFixedTypeName & "',strFullName='" _
                        & .strFullName & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) _
                        & ",intLevel =" & .intLevel & ",blnIsDetail=" & IIf(.blnIsDetail, 1, 0) _
                        & ",strDepreciationType ='" & .strDepreciationType _
                        & "',strDepreciationMethod='" & .strDepreciationMethod _
                        & "',dblNetWorthRate =" & .dblNetWorthRate & ",dblTotalWork=" _
                        & .dblTotalWork & ",intUseAge=" & .intUseAge _
                        & " WHERE lngFixedTypeID=" & .lngFixedTypeID   '修改数据库
                End If
                recSelect.Close
                Exit Function
            End If
        Else '编码未改变
            If .strFixedTypeName <> txtInput(1).Text Then  '名称已改变，得出全名
                strNewFullName = strLeft(.strFullName, strLen(.strFullName) - _
                    strLen(.strFixedTypeName)) & txtInput(1).Text
                If Not UpdateChild(txtInput(0).Text, .strFixedTypeCode, strNewFullName) Then  '修改下级编码
                    validityCheck = False
                    InputAgain
                    Exit Function
                End If
                .strFullName = strNewFullName
            End If
            SettingRecord '整理记录
            SetBuffer "UPDATE FixedType SET strFixedTypeCode='" & .strFixedTypeCode _
                & "',strFixedTypeName='" & .strFixedTypeName & "',strFullName='" _
                & .strFullName & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) _
                & ",intLevel =" & .intLevel & ",blnIsDetail=" & IIf(.blnIsDetail, 1, 0) _
                & ",strDepreciationType ='" & .strDepreciationType _
                & "',strDepreciationMethod='" & .strDepreciationMethod _
                & "',dblNetWorthRate =" & .dblNetWorthRate & ",dblTotalWork=" _
                & .dblTotalWork & ",intUseAge=" & .intUseAge _
                & " WHERE lngFixedTypeID=" & .lngFixedTypeID   '修改数据库
        End If
    End With
End Function


'存入数据库之前整理记录值
Private Sub SettingRecord()
    With mftrFixedType
        .intLevel = strCount(txtInput(0).Text, "-") + 1
        If chkPause.Value = Checked Then
            .blnIsInActive = True
        Else
            .blnIsInActive = False
        End If
        .strFixedTypeCode = txtInput(0).Text
        .strFixedTypeName = txtInput(1).Text
        .dblNetWorthRate = txtInput(2).Text
        If strLen(Trim(cboFixedType(0).Text)) = 0 Then
            .strDepreciationType = "0"
        Else
            .strDepreciationType = CStr(cboFixedType(0).ListIndex + 1)
        End If
        If strLen(Trim(cboFixedType(0).Text)) = 0 Then
            .strDepreciationMethod = "0"
        Else
            .strDepreciationMethod = CStr(cboFixedType(1).ListIndex + 1)
        End If
        If txtInput(3).Text <> "" Then
            If cboFixedType(1).ListIndex = 2 Then
                .dblTotalWork = txtInput(3).Text
                .intUseAge = 0
            Else
                .intUseAge = txtInput(3).Text
                .dblTotalWork = 0
            End If
        End If
    End With
End Sub

'修改新的上级编码的末级属性，并返回本级编码的全名
Private Function UpdateNewParent(strChildCode As String, blnChildIsDetail As Boolean) As String
    Dim strParentCode As String
    Dim strParentname As String
    Dim strChildName As String
    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer

    strParentCode = CodePrefix(strChildCode) '分离出上级编码
    strSql = "SELECT lngFixedTypeID,strFullName,blnIsDetail FROM FixedType" & _
        "  WHERE strFixedTypeCode='" & strParentCode & "'"
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSelect.RowCount = 0 Then
        ShowMsg 0, "此固定资产类别编码的上级编码不存在，请重新输入。", _
                  vbExclamation + MB_TASKMODAL, Me.Caption
        recSelect.Close
        Exit Function
    End If
    strParentname = recSelect!strFullName   '得到上级编码的全名
    strChildName = strParentname & "-" & txtInput(1).Text '得到本级编码的全名
    If recSelect!blnIsDetail Then
        If blnChildIsDetail Then '上级和新下级都是末级才能转业务
            If CodeUsed(recSelect!lngFixedTypeID) Then '判断编码是否被使用
                intMsgReturn = ShowMsg(0, "其它地方正在使用此固定资产类别编码的上级编码，" _
                    & "是否将上级编码的业务转到此固定资产类别编码？", _
                    vbExclamation + vbOKCancel + MB_TASKMODAL, frmFixedTypeListCard.Caption)
                If intMsgReturn = vbCancel Then
                    recSelect.Close
                    Exit Function
                Else
                    mlngUniteID = recSelect!lngFixedTypeID '存储上级ID以便转业务
                End If
            End If
            SetBuffer "UPDATE FixedType SET blnIsDetail=False WHERE lngFixedTypeID=" _
                & recSelect!lngFixedTypeID    '修改上级编码的末级属性为假
        Else '不能转移业务
            ShowMsg 0, "上级编码的业务不能转到此固定资产类别编码，请重新输入。", _
                    vbExclamation + MB_TASKMODAL, Me.Caption
            recSelect.Close
            Exit Function
        End If
    End If
    UpdateNewParent = strChildName
    recSelect.Close
End Function

'修改老的上级编码的末级属性
Private Sub UpdateOldParent(strChildCode As String)
    Dim strParentCode As String
    Dim strSql As String
    Dim recSelect As rdoResultset

    strParentCode = CodePrefix(strChildCode) '分离出上级编码
    strSql = "SELECT strFixedTypeCode FROM FixedType WHERE strFixedTypeCode LIKE '" _
        & strParentCode & "-*' and strFixedTypeCode  not LIKE '" & _
        strChildCode & "*'"  '查找此上级编码的其它下级编码
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSelect.RecordCount = 0 Then  '此上级编码没有其它下级编码
        SetBuffer "UPDATE FixedType SET blnIsDetail=1 WHERE " & _
            "strFixedTypeCode='" & strParentCode & "'"  '修改上级编码的末级属性为真
    End If
    recSelect.Close
End Sub


'修改下级编码的属性
Private Function UpdateChild(strParentNewCode As String, strParentOldCode As String, _
    strParentFullName As String) As Boolean
    Dim strChildNewCode As String
    Dim strChildFullName As String
    Dim intChildNewLevel As Integer
    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer

    UpdateChild = True
    strSql = "SELECT strFixedTypeCode,strFixedTypeName FROM FixedType " _
        & " WHERE strFixedTypeCode LIKE '" & strParentOldCode & "-*'"
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic) '查找下级编码
    Do While Not recSelect.EOF
        strChildNewCode = strParentNewCode & strRight(recSelect!strFixedTypeCode, _
            strLen(recSelect!strFixedTypeCode) - strLen(strParentOldCode))
        strChildFullName = strParentFullName & "-" & recSelect!strFixedTypeName
        intChildNewLevel = strCount(strChildNewCode, "-") + 1
        If strLen(strChildNewCode) > 16 Then '判断新下级编码合法性
            intMsgReturn = ShowMsg(0, "此固定资产类别的编码太长，请重新输入。", _
                vbExclamation + vbOKOnly + MB_TASKMODAL, Me.Caption)
            UpdateChild = False
            recSelect.Close
            Exit Do
        Else '修改下级编码
            SetBuffer "UPDATE FixedType SET strFixedTypeCode='" & strChildNewCode & _
                "',strFullName='" & strChildFullName & "',intLevel=" & intChildNewLevel & _
                "  WHERE strFixedTypeCode='" & recSelect!strFixedTypeCode & "'"
        End If
        recSelect.MoveNext
    Loop
    recSelect.Close
End Function

'查找出非末级的下级编码ID，为将非末级的下级编码全合并到合并对象(末级)作准备。
Private Function UniteChild(strParentCode As String) As String
    Dim strChildID As String '下级编码ID和逗号组成的字符串
    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer
    
    strChildID = ""
    strSql = "SELECT lngFixedTypeID FROM FixedType WHERE strFixedTypeCode LIKE '" _
        & strParentCode & "-*'"
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic) '查找下级编码
    Do While Not recSelect.EOF
        If strChildID <> "" Then
            strChildID = strChildID & ","
        End If
        strChildID = strChildID & CStr(recSelect!lngFixedTypeID)
        recSelect.MoveNext
    Loop
    recSelect.Close
    UniteChild = strChildID
End Function

'合并或转业务：查找出使用原编码的记录，将其修改为使用现编码
'blnDeleteOld：真，需删除原编码（同名末级合并）；假，不删除原编码（上下级编码转业务）
Private Sub UniteRecord(strOldID As String, lngNewID As Long, blnDeleteOld As Boolean)
    SetBuffer "UPDATE FixedCard SET lngFixedTypeID=" & lngNewID _
        & " WHERE lngFixedTypeID IN (" & strOldID & ")"
    If blnDeleteOld Then
        SetBuffer "DELETE FROM FixedType WHERE lngFixedTypeID IN (" & strOldID & ")"
    End If
End Sub

'把对数据库的增删改操作暂时存储在数组中
Private Sub SetBuffer(strSql As String)
    If mintSQLIndex = 0 Then
        ReDim mstrSQLBuffer(0)
    Else
        ReDim Preserve mstrSQLBuffer(UBound(mstrSQLBuffer) + 1)
    End If
    mstrSQLBuffer(mintSQLIndex) = strSql
    mintSQLIndex = mintSQLIndex + 1
End Sub

'清空暂时存储数据库操作的数组
Private Sub InitBuffer()
    ReDim mstrSQLBuffer(0)
    mintSQLIndex = 0
End Sub

'执行暂时存储在数组中的数据库操作
Private Function ExecBuffer() As Boolean
    Dim blnExecSQL As Boolean
    Dim intSQLIndex As Integer

    If mintSQLIndex = 0 Then
        ExecBuffer = True
        Exit Function
    End If
    For intSQLIndex = 0 To mintSQLIndex - 1
        blnExecSQL = gclsBase.ExecSQL(mstrSQLBuffer(intSQLIndex))
        If Not blnExecSQL Then Exit For
    Next intSQLIndex
    ExecBuffer = blnExecSQL
End Function



Public Property Get FixedTypeID() As Variant
    FixedTypeID = mftrFixedType.lngFixedTypeID
End Property