frmvouchertypelistcard.frm

金算盘软件代码

    For i = 0 To 4 Step 2
        For intIndex = 6 To 7
            If (lstAccount(intIndex).ID = lstAccount(i).ID And lstAccount(intIndex).ID <> 0 _
                And lstAccount(i).Text <> "") _
                Or (lstAccount(intIndex).ID = lstAccount(i + 1).ID And lstAccount(intIndex).ID <> 0 _
                And lstAccount(i + 1).Text <> "") _
                    And lstAccount(intIndex).Text <> "" Then
                '判断同一科目不能既是凭证必有科目又是凭证必无科目
                lstAccount(intIndex).SeekId (lstAccount(intIndex).ID)
                
                Select Case i
                       Case 0
                            ShowMsg 0, "同一科目不能既是借方必有科目又是凭证必无科目!", _
                                        vbExclamation + MB_TASKMODAL, Me.Caption
                       Case 2
                            ShowMsg 0, "同一科目不能既是贷方必有科目又是凭证必无科目。", _
                                        vbExclamation + MB_TASKMODAL, Me.Caption
                       Case 4
                            ShowMsg 0, "同一科目不能既是凭证必有科目又是凭证必无科目。", _
                                        vbExclamation + MB_TASKMODAL, Me.Caption
                End Select
                lstAccount(intIndex).SelStart = 0
                lstAccount(intIndex).SelLength = strLen(lstAccount(intIndex).Text)
                lstAccount(intIndex).SetFocus
                validityCheck = False
                Exit Function
            End If
        Next intIndex
    Next i
    
    With mvcrVoucherType
        If .strVoucherTypeCode <> txtInput(0).Text Then         '编码已改变
            strSql = "SELECT * FROM VoucherType WHERE strVoucherTypeCode='" & _
                txtInput(0).Text & "'"
            Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recSelect.RowCount <> 0 Then         '编码不唯一
                If mblnAddRecord Then    '新增编码不能合并
                    intMsgReturn = ShowMsg(0, "此凭证类型编码已存在，请从新输入。", _
                        vbExclamation + MB_TASKMODAL, Me.Caption)
                    validityCheck = False
                    InputAgain
                    recSelect.Close
                    Exit Function
                Else '修改编码可合并
                    intMsgReturn = ShowMsg(0, "此凭证类型编码已存在，是否想合并？", _
                        vbExclamation + MB_TASKMODAL, Me.Caption)
                    If intMsgReturn = vbOK Then '合并
                        UniteRecord .lngVoucherTypeID, recSelect!lngVoucherTypeID, True   '修改原编码的被使用情况
                        .lngVoucherTypeID = recSelect!lngVoucherTypeID
                        SettingRecord '整理记录
                        SetBuffer "UPDATE VoucherType SET strVoucherTypeCode='" & _
                            .strVoucherTypeCode & "',strVoucherTypeName='" & _
                            .strVoucherTypeName & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) & _
                            ",lngDebitAccountID1=" & .lngDebitAccountID1 & _
                            ",lngDebitAccountID2=" & .lngDebitAccountID2 & _
                            ",lngCreditAccountID1=" & .lngCreditAccountID1 & _
                            ",lngCreditAccountID2=" & .lngCreditAccountID2 & _
                            ",lngVoucherAccountID1=" & .lngVoucherAccountID1 & _
                            ",lngVoucherAccountID2=" & .lngVoucherAccountID2 & _
                            ",lngVoucherNOAccountID1=" & .lngVoucherNOAccountID1 & _
                            ",lngVoucherNOAccountID2=" & .lngVoucherNOAccountID1 & _
                            " WHERE lngVoucherTypeID=" & .lngVoucherTypeID '修改数据库记录
                        recSelect.Close
                    Else '不想合并
                        validityCheck = False
                        InputAgain
                        recSelect.Close
                        Exit Function
                    End If
                End If
            Else '编码唯一
                SettingRecord '整理记录
                If mblnAddRecord Then
                    SetBuffer "INSERT INTO VoucherType (strVoucherTypeCode," & _
                        "strVoucherTypeName,blnIsInActive,lngDebitAccountID1," & _
                        "lngDebitAccountID2,lngCreditAccountID1,lngCreditAccountID2," & _
                        "lngVoucherAccountID1,lngVoucherAccountID2,lngVoucherNOAccountID1" & _
                        ",lngVoucherNOAccountID2) VALUES ( '" & .strVoucherTypeCode & _
                        "','" & .strVoucherTypeName & "'," & IIf(.blnIsInActive, 1, 0) & "," & _
                        .lngDebitAccountID1 & "," & .lngDebitAccountID2 & "," & _
                        .lngCreditAccountID1 & "," & .lngCreditAccountID2 & "," & _
                        .lngVoucherAccountID1 & "," & .lngVoucherAccountID2 & "," & _
                        .lngVoucherNOAccountID1 & "," & .lngVoucherNOAccountID2 & ")" '插入数据库记录
                Else
                    SetBuffer "UPDATE VoucherType SET strVoucherTypeCode='" & _
                        .strVoucherTypeCode & "',strVoucherTypeName='" & _
                        .strVoucherTypeName & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) & _
                        ",lngDebitAccountID1=" & .lngDebitAccountID1 & _
                        ",lngDebitAccountID2=" & .lngDebitAccountID2 & _
                        ",lngCreditAccountID1=" & .lngCreditAccountID1 & _
                        ",lngCreditAccountID2=" & .lngCreditAccountID2 & _
                        ",lngVoucherAccountID1=" & .lngVoucherAccountID1 & _
                        ",lngVoucherAccountID2=" & .lngVoucherAccountID2 & _
                        ",lngVoucherNOAccountID1=" & .lngVoucherNOAccountID1 & _
                        ",lngVoucherNOAccountID2=" & .lngVoucherNOAccountID1 & _
                        " WHERE lngVoucherTypeID=" & .lngVoucherTypeID '修改数据库记录
                End If
                recSelect.Close
            End If
        Else '编码未改变
            SettingRecord '整理记录
            SetBuffer "UPDATE VoucherType SET strVoucherTypeCode='" & _
                .strVoucherTypeCode & "',strVoucherTypeName='" & _
                .strVoucherTypeName & "',blnIsInActive=" & IIf(.blnIsInActive, 1, 0) & _
                ",lngDebitAccountID1=" & .lngDebitAccountID1 & _
                ",lngDebitAccountID2=" & .lngDebitAccountID2 & _
                ",lngCreditAccountID1=" & .lngCreditAccountID1 & _
                ",lngCreditAccountID2=" & .lngCreditAccountID2 & _
                ",lngVoucherAccountID1=" & .lngVoucherAccountID1 & _
                ",lngVoucherAccountID2=" & .lngVoucherAccountID2 & _
                ",lngVoucherNOAccountID1=" & .lngVoucherNOAccountID1 & _
                ",lngVoucherNOAccountID2=" & .lngVoucherNOAccountID2 & _
                " WHERE lngVoucherTypeID=" & .lngVoucherTypeID '修改数据库记录
        End If
    End With
End Function


'存入数据库之前整理记录值
Private Sub SettingRecord()
    With mvcrVoucherType
        .strVoucherTypeCode = txtInput(0).Text
        .strVoucherTypeName = txtInput(1).Text
        If chkPause.Value = Checked Then
            .blnIsInActive = True
        Else
            .blnIsInActive = False
        End If
        If lstAccount(0).Text = "" Then
            .lngDebitAccountID1 = 0
        Else
            If lstAccount(0).Referrows > 1 Then .lngDebitAccountID1 = lstAccount(0).ID
        End If
        If lstAccount(1).Text = "" Then
            .lngDebitAccountID2 = 0
        Else
            If lstAccount(1).Referrows > 1 Then .lngDebitAccountID2 = lstAccount(1).ID
        End If
        If lstAccount(2).Text = "" Then
            .lngCreditAccountID1 = 0
        Else
            If lstAccount(2).Referrows > 1 Then .lngCreditAccountID1 = lstAccount(2).ID
        End If
        If lstAccount(3).Text = "" Then
            .lngCreditAccountID2 = 0
        Else
            If lstAccount(3).Referrows > 1 Then .lngCreditAccountID2 = lstAccount(3).ID
        End If
        If lstAccount(4).Text = "" Then
            .lngVoucherAccountID1 = 0
        Else
           If lstAccount(4).Referrows > 1 Then .lngVoucherAccountID1 = lstAccount(4).ID
        End If
        If lstAccount(5).Text = "" Then
            .lngVoucherAccountID2 = 0
        Else
            If lstAccount(5).Referrows > 1 Then .lngVoucherAccountID2 = lstAccount(5).ID
        End If
        If lstAccount(6).Text = "" Then
            .lngVoucherNOAccountID1 = 0
        Else
            If lstAccount(6).Referrows > 1 Then .lngVoucherNOAccountID1 = lstAccount(6).ID
        End If
        If lstAccount(7).Text = "" Then
            .lngVoucherNOAccountID2 = 0
        Else
            If lstAccount(7).Referrows > 1 Then .lngVoucherNOAccountID2 = lstAccount(7).ID
        End If
    End With
End Sub

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

'根据列表框输入信息来调用卡片
Private Sub lstAccount_ItemNotExist(Index As Integer)
    Dim intMsgReturn As Integer
    Dim lngID As Long
    
    intMsgReturn = frmMsgAdd.MsgAddShow("科目不存在", "科目列表中没有'" _
        & lstAccount(Index).Text & "'！")
    If intMsgReturn = vbOK Then
        lngID = mlngListIDBuffer(Index)
        mstrListTextBuffer(Index) = lstAccount(Index).Text
        mlngListIDBuffer(Index) = Card.AddCard(Message.msgAccount, mstrListTextBuffer(Index))
        If mlngListIDBuffer(Index) > 0 Then
           Select Case Index
                  Case 0
                       mvcrVoucherType.lngDebitAccountID1 = mlngListIDBuffer(0)
                  Case 1
                       mvcrVoucherType.lngDebitAccountID2 = mlngListIDBuffer(1)
                  Case 2
                       mvcrVoucherType.lngCreditAccountID1 = mlngListIDBuffer(2)
                  Case 3
                       mvcrVoucherType.lngCreditAccountID2 = mlngListIDBuffer(3)
                  Case 4
                       mvcrVoucherType.lngVoucherAccountID1 = mlngListIDBuffer(4)
                  Case 5
                       mvcrVoucherType.lngVoucherAccountID2 = mlngListIDBuffer(5)
                  Case 6
                       mvcrVoucherType.lngVoucherNOAccountID1 = mlngListIDBuffer(6)
                  Case 7
                       mvcrVoucherType.lngVoucherNOAccountID2 = mlngListIDBuffer(7)
           End Select
           setlistbox lstAccount(0), 0
           setlistbox lstAccount(1), 1
           setlistbox lstAccount(2), 2
           setlistbox lstAccount(3), 3
           setlistbox lstAccount(4), 4
           setlistbox lstAccount(5), 5
           setlistbox lstAccount(6), 6
           setlistbox lstAccount(7), 7
        Else
           If lngID = 0 Then
              lstAccount(Index).Text = ""
              Exit Sub
           Else
              lstAccount(Index).SeekId lngID
              Exit Sub
           End If
        End If
        lstAccount(Index).SeekId mlngListIDBuffer(Index)
    Else
        lstAccount(Index).Text = ""
        lstAccount(Index).SelStart = 0
        lstAccount(Index).SelLength = strLen(lstAccount(Index).Text)
        lstAccount(Index).SetFocus
    End If

End Sub


Private Sub lstAccount_KeyPress(Index As Integer, KeyAscii As Integer)
mblnIsChanged = True
End Sub

Private Sub lstAccount_LostFocus(Index As Integer)
    If mblnAddRecord Then
       cmdOKCancel(2).Default = True
    Else
       cmdOKCancel(0).Default = True
    End If
End Sub

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

Private Sub txtInput_Change(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
End Sub

Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
mblnIsChanged = True
End Sub

Public Property Get VoucherTypeID() As Long
       VoucherTypeID = mvcrVoucherType.lngVoucherTypeID
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