frmfixedmethodlistcard.frm

金算盘软件代码

            lstMethod(Index).SelLength = strLen(lstMethod(Index).Text)
            'frmFixedMethodListCard.lstMethod(Index).SetFocus
            Select Case Index
                   Case 0
                        SendKeys "%{A}"
                   Case 1
                        SendKeys "%{T}"
                   Case 2
                        SendKeys "%{L}"
           End Select
    End Select
End Sub

Private Sub lstMethod_KeyPress(Index As Integer, KeyAscii As Integer)
    If Index = 2 Then Exit Sub
    If KeyAscii = 13 Then
       SendKeys "{TAB}"
    End If

End Sub

Private Sub lstMethod_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
     If Index = 3 Then mtext = lstMethod(Index).Text
End Sub

Private Sub lstMethod_LostFocus(Index As Integer)
    Dim lngID As Long
    Dim strSql As String
    Dim recAccount As rdoResultset
    
    If Index = 0 Then
       If mblnIsEditAdd = False Then
          lngID = lstMethod(0).ID 'TextMatrix(lstMethod(0).ReferRow, 1)
          If lngID > 0 Then
             strSql = "select * from Account where lngAccountID=" & lngID & " and blnIsDetail=1"
             Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
             If recAccount.EOF Then
                ShowMsg 0, "“" & lstMethod(0).Text & "“会计科目不是末级科目，请重新选择会计科目！", _
                       vbExclamation + MB_TASKMODAL, Me.Caption
                lstMethod(0).SelStart = 0
                lstMethod(0).SelLength = strLen(lstMethod(0).Text)
                lstMethod(0).SetFocus
                Exit Sub
             End If
          End If
       End If
    End If
    mblnIsEditAdd = False
'    mblnIsChanged = True
    If mblnAddRecord Then
       cmdOKCancel(2).Default = True
    Else
       cmdOKCancel(0).Default = True
    End If
End Sub

Private Sub lstMethod_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Index = 3 Then
       If lstMethod(3).ID = 0 Then lstMethod(3).Text = mtext 'sdfdsf
    End If
End Sub

Private Sub optType_Click(Index As Integer)
    mblnIsChanged = True
End Sub

Private Sub txtInput_Change(Index As Integer)
    If ContainErrorChar(txtInput(Index).Text, "'|") Then
       BKKEY txtInput(Index).hwnd
       Exit Sub
    End If
End Sub

Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii = 13 Then
       SendKeys "{TAB}"
    End If

End Sub

Private Sub txtInput_LostFocus(Index As Integer)
    Dim intMsgReturn As Integer

'    If txtInput(Index).Text <> "" Then
''        If ContainErrorChar(txtInput(Index).Text) Then
''            intMsgReturn = ShowMsg(0, "输入非法字符。", _
''                vbExclamation + MB_TASKMODAL, Me.Caption)
''            txtInput(Index).SelStart = 0
''            txtInput(Index).SelLength = strLen(txtInput(Index).Text)
''            txtInput(Index).SetFocus
''        End If
'    End If
    mblnIsChanged = True
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    Dim strSql As String
    Dim recType As rdoResultset
    
    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) As Boolean
    Dim intMsgReturn As Integer
    Dim intCounter As Integer
    Dim strCode As String
    
    strCode = Trim(txtInput(0).Text)
    SaveCard = False
    If validityCheck() Then '检查数据的有效性并整理记录值成功
        gclsBase.BaseWorkSpace.BeginTrans
        If ExecBuffer Then  '修改数据库成功
            gclsBase.BaseWorkSpace.CommitTrans
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgFixedMethod
            SaveCard = True
            If Not blnClickOK Then
                InitAddCard '为新增记录作设置
                txtInput(0).Text = GetNextCode(strCode)
                'txtInput(0).Text = GetNextCode(txtInput(0).Text)
                InputAgain
            Else
                For intCounter = 0 To 3
                     mlngListIDBuffer(intCounter) = 0
                Next intCounter
            End If
        Else '修改数据库不成功
            gclsBase.BaseWorkSpace.RollbackTrans
            mblnAddRecord = True
            InitAddCard '初始化
            InputAgain
        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() As Boolean
    Dim recSelect As rdoResultset
    Dim strSql As String

    validityCheck = True
    If IsInputRight = False Then
       validityCheck = False
       Exit Function
    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          '编码不唯一
            ShowMsg 0, "此固资变动方式编码已存在，请重新输入！", _
                       vbExclamation + MB_TASKMODAL, Me.Caption
            validityCheck = False
            InputAgain
            recSelect.Close
            Exit Function
         End If
         
         If Not SettingRecord Then
            validityCheck = False
            Exit Function
         End If   '整理记录
         If mblnAddRecord Then
            SetBuffer "INSERT INTO FixedMethod (strFixedMethodCode,strFixedMethodName," _
                      & "blnIsInActive,strFixedMethodType,lngAccountID,lngTemplateID," _
                      & "lngVoucherTypeID,strRemark,strStartDate) VALUES ('" & .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() As Boolean
    Dim strSql As String
    Dim recAccount As rdoResultset
    Dim lngNatureID As Long
    
    SettingRecord = False
    With mfmrFixedMethod
        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
        
        strSql = "select lngAccountNatureID from Account where lngAccountID=" & .lngAccountID
        Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recAccount.EOF Then
            lngNatureID = recAccount.rdoColumns(0)
            If lngNatureID <> 0 Then
'               If gclsBase.ControlAccount = True Then
                  ShowMsg 0, "变动方式的科目不能为科目性质为“现金，银行，应收，应付,存货”的科目！", _
                             vbExclamation + MB_SYSTEMMODAL, Me.Caption
                  lstMethod(0).SelStart = 0
                  lstMethod(0).SelLength = strLen(lstMethod(0).Text)
                  lstMethod(0).SetFocus
                  Exit Function
'               ElseIf lngNatureID = 5 Then
'                  ShowMsg 0, "变动方式的科目不能为科目性质为“存货”的科目！", _
'                             vbExclamation + MB_SYSTEMMODAL, Me.Caption
'                  lstMethod(0).SelStart = 0
'                  lstMethod(0).SelLength = strLen(lstMethod(0).Text)
'                  lstMethod(0).SetFocus
'                  Exit Function
'               End If
            End If
        End If
        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 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

Private Sub txtInput_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    mblnIsChanged = True
End Sub