frmfixedmethodcard.frm

金算盘软件代码

'    End If
    mblnIsChanged = True
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    Dim strSql As String
    Dim recType As rdoResultset
    
    If mblnIsExist Then Exit Sub
    Select Case Index
        Case 0    '确定
            If SaveCard(True) Then
'               strSql = "select * from FixedMethod order by lngFixedMethodID"
'               Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'               If recType.RowCount > 0 Then
'                  recType.MoveLast
'                  ID = recType!lngFixedMethodID
'               Else
'                  ID = 0
'               End If
               Unload Me
               Exit Sub
            End If
        Case 1    '取消
            Unload Me
            Exit Sub
        Case 2    '下一个
            SaveCard False
    End Select
End Sub

'通过事务处理完成对数据库的操作
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function SaveCard(blnClickOK As Boolean, Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim intMsgReturn As Integer
    Dim intCounter As Integer

    SaveCard = False
    If mblnIsExist Then Exit Function
    If validityCheck(blnByAdd) Then '检查数据的有效性并整理记录值成功
        gclsBase.BaseWorkSpace.BeginTrans
        If ExecBuffer Then  '修改数据库成功
            gclsBase.BaseWorkSpace.CommitTrans
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgFixedMethod
            SaveCard = True
            If Not blnClickOK Then
                InitAddCard '为新增记录作设置
                InputAgain
            Else
                For intCounter = 0 To 3
                     mlngListIDBuffer(intCounter) = 0
                Next intCounter
            End If
        Else '修改数据库不成功
            gclsBase.BaseWorkSpace.RollBacktrans
            mblnAddRecord = True
            If Not blnByAdd Then
                InitAddCard '初始化
                InputAgain
            End If
        End If
    Else '检查数据的有效性并整理记录值不成功
        InitBuffer   '清空暂时存储数据库操作的数组
    End If
End Function

'检查数据的有效性
Private Function IsInputRight() As Boolean
    
    IsInputRight = False
    If StrLen(Trim(txtInput(0).Text)) = 0 Then  '检查非空项
        ShowMsg 0, " 固资变动方式编码必需输入！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
        InputAgain
        Exit Function
    Else
        If InStr(1, txtInput(0).Text, "'") <> 0 Then
           ShowMsg 0, " 固资变动方式编码中不能有‘'’符号！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
           InputAgain
           Exit Function
        End If
    End If
    If StrLen(Trim(txtInput(1).Text)) = 0 Then  '检查非空项
        ShowMsg 0, " 固资变动方式名称必需输入！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
        txtInput(1).SelStart = 0
        txtInput(1).SelLength = StrLen(txtInput(1).Text)
        txtInput(1).SetFocus
        Exit Function
    Else
        If InStr(1, txtInput(1).Text, "'") <> 0 Then
           ShowMsg 0, " 固资变动方式名称中不能有‘'’符号！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
            txtInput(1).SelStart = 0
            txtInput(1).SelLength = StrLen(txtInput(1).Text)
            txtInput(1).SetFocus
            Exit Function
        End If
    End If

    If StrLen(Trim(lstMethod(1).Text)) = 0 Then   '检查非空项
        ShowMsg 0, " 凭证模版必需输入！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
        lstMethod(1).SelStart = 0
        lstMethod(1).SelLength = StrLen(lstMethod(1).Text)
        lstMethod(1).SetFocus
        Exit Function
    End If
    If StrLen(Trim(lstMethod(2).Text)) = 0 Then   '检查非空项
        ShowMsg 0, " 凭证类型必需输入！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
        lstMethod(2).SelStart = 0
        lstMethod(2).SelLength = StrLen(lstMethod(2).Text)
        lstMethod(2).SetFocus
        Exit Function
    End If
    IsInputRight = True
End Function

'并整理记录值,存储记录
Private Function validityCheck(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim recSelect As rdoResultset
    Dim strSql As String

    validityCheck = True
    If Not blnByAdd Then
        If IsInputRight = False Then
           validityCheck = False
           Exit Function
        End If
    End If
    
    With mfmrFixedMethod
         strSql = "SELECT * FROM FixedMethod WHERE strFixedMethodCode='" _
                  & txtInput(0).Text & "' and lngfixedmethodid<>" & .lngFixedMethodID
         Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
         If recSelect.RowCount <> 0 Then         '编码不唯一
            If Not blnByAdd Then
                ShowMsg 0, "此固资变动方式编码已存在，请重新输入！", _
                           vbExclamation + MB_TASKMODAL, Me.Caption
                InputAgain
            End If
            validityCheck = False
            recSelect.Close
            Exit Function
         End If
         
        If Not SettingRecord(blnByAdd) Then
           validityCheck = False
           Exit Function
        End If   '整理记录
         If mblnAddRecord Then
            ID = GetNewID("FixedMethod")
            SetBuffer "INSERT INTO FixedMethod (lngFixedMethodID,strFixedMethodCode,strFixedMethodName," _
                      & "blnIsInActive,strFixedMethodType,lngAccountID,lngTemplateID," _
                      & "lngVoucherTypeID,strRemark,strStartDate) VALUES(" & ID & ",'" & .strFixedMethodCode & "','" _
                      & .strFixedMethodName & "'," & IIf(.blnIsInActive, 1, 0) & ",'" _
                      & .strFixedMethodType & "'," & .lngAccountID & "," & .lngTemplateID _
                      & "," & .lngVoucherTypeID & ",'" & .strRemark & "','" & Format(Date, "yyyy-mm-dd") & "')" '插入数据库记录
         Else
            SetBuffer "UPDATE FixedMethod SET strFixedMethodCode='" _
                      & .strFixedMethodCode & "',strFixedMethodName='" & .strFixedMethodName _
                      & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) & ",strFixedMethodType='" _
                      & .strFixedMethodType & "',lngAccountID=" & .lngAccountID _
                      & ",lngTemplateID=" & .lngTemplateID & ",lngVoucherTypeID=" _
                      & .lngVoucherTypeID & ",strRemark='" & .strRemark _
                      & "' WHERE lngFixedMethodID=" & .lngFixedMethodID  '修改数据库记录
         End If
    End With
End Function

'存入数据库之前整理记录值
Private Function SettingRecord(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim strSql As String
    Dim recAccount As rdoResultset
    Dim lngNatureID As Long
    
    SettingRecord = False
    With mfmrFixedMethod
        If Not blnByAdd Then
            If chkPause.Value = Checked Then
                .blnIsInActive = True
            Else
                .blnIsInActive = False
            End If
            If lstMethod(0).Text = "" Then
                .lngAccountID = 0
            Else
                If lstMethod(0).Referrows > 1 Then .lngAccountID = lstMethod(0).ID
            End If
        End If
        strSql = "select lngAccountNatureID,blnIsDetail from Account where lngAccountID=" & .lngAccountID
        Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recAccount.EOF Then
            If recAccount.rdoColumns(1) = 0 Then
                If Not blnByAdd Then
                        ShowMsg 0, "变动方式的科目只能是末级科目！", _
                                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
                        lstMethod(0).SelStart = 0
                        lstMethod(0).SelLength = StrLen(lstMethod(0).Text)
                        lstMethod(0).SetFocus
                End If
                Exit Function
            End If
            lngNatureID = recAccount.rdoColumns(0)
            If lngNatureID <> 0 Then
               If gclsBase.ControlAccount = True Then
                    If Not blnByAdd Then
                        ShowMsg 0, "变动方式的科目不能为科目性质为“现金，银行，应收，应付,存货”的科目！", _
                                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
                        lstMethod(0).SelStart = 0
                        lstMethod(0).SelLength = StrLen(lstMethod(0).Text)
                        lstMethod(0).SetFocus
                    End If
                  Exit Function
               ElseIf lngNatureID = 5 Then
                    If Not blnByAdd Then
                        ShowMsg 0, "变动方式的科目不能为科目性质为“存货”的科目！", _
                                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
                        lstMethod(0).SelStart = 0
                        lstMethod(0).SelLength = StrLen(lstMethod(0).Text)
                        lstMethod(0).SetFocus
                    End If
                  Exit Function
               End If
            End If
        End If
        If Not blnByAdd Then
            If lstMethod(1).Text = "" Then
                .lngTemplateID = 0
            Else
                If lstMethod(1).Referrows > 1 Then .lngTemplateID = lstMethod(1).ID
            End If
            If lstMethod(2).Text = "" Then
                .lngVoucherTypeID = 0
            Else
                If lstMethod(2).Referrows > 1 Then .lngVoucherTypeID = lstMethod(2).ID
            End If
            If lstMethod(3).Text = "" Then
                .strRemark = " "
            Else
                If lstMethod(3).ReferRow > 1 Then
                   .strRemark = lstMethod(3).TextMatrix(lstMethod(3).ReferRow, 3)
                Else
                   .strRemark = lstMethod(3).Text
                End If
            End If
            .strFixedMethodCode = txtInput(0).Text
            .strFixedMethodName = txtInput(1).Text
            If optType(0).Value = True Then
                .strFixedMethodType = "1"
            Else
                .strFixedMethodType = "0"
            End If
        End If
    End With
    SettingRecord = True
End Function

'合并或转业务：查找出使用原编码的记录，将其修改为使用现编码
'blnDeleteOld：真，需删除原编码（同名末级合并）；假，不删除原编码（上下级编码转业务）
Private Sub UniteRecord(lngOldID As Long, lngNewID As Long, blnDeleteOld As Boolean)
    SetBuffer "UPDATE FixedAlter SET lngFixedMethodID=" & lngNewID _
        & " WHERE lngFixedMethodID=" & lngOldID
    
    If blnDeleteOld Then
        SetBuffer "DELETE FROM FixedMethod WHERE lngFixedMethodID = " & lngOldID
    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 FixedMethodID() As Long
       FixedMethodID = mfmrFixedMethod.lngFixedMethodID
End Property