frmentrytypecard.frm

金算盘软件代码

            mblnAddRecord = True
            InitAddCard '初始化
            InputAgain
        End If
    Else '检查数据的有效性并整理记录值不成功
        InitBuffer   '清空暂时存储数据库操作的数组
    End If
End Function

'检查数据的有效性
Private Function IsInputRight() As Boolean
    Dim i As Integer
    Dim intIndex As Integer
    
    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_SYSTEMMODAL, 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_SYSTEMMODAL, Me.Caption
          txtInput(1).SelStart = 0
          txtInput(1).SelLength = StrLen(txtInput(1).Text)
          txtInput(1).SetFocus
          Exit Function
       End If
    End If
    '判断同一科目不能既是凭证必有科目又是凭证必无科目
    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
                Exit Function
            End If
        Next intIndex
    Next i
    
    IsInputRight = True
End Function

'整理记录值,存储记录
Private Function validityCheck(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim strSQL As String
    Dim recSelect As rdoResultset
    
    validityCheck = True
    If Not blnByAdd Then
        If IsInputRight = False Then
           validityCheck = False
           Exit Function
        End If
    End If
    With mvcrVoucherType
         strSQL = "SELECT * FROM VoucherType WHERE strVoucherTypeCode='" & _
                  txtInput(0).Text & "' and lngvouchertypeID<>" & .lngVoucherTypeID
         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 blnByAdd Then SettingRecord '整理记录
         If mblnAddRecord Then
            ID = GetNewID("VoucherType")
            SetBuffer "INSERT INTO VoucherType (lngVoucherTypeID,strVoucherTypeCode," & _
                      "strVoucherTypeName,blnIsInActive,lngDebitAccountID1," & _
                      "lngDebitAccountID2,lngCreditAccountID1,lngCreditAccountID2," & _
                      "lngVoucherAccountID1,lngVoucherAccountID2,lngVoucherNOAccountID1" & _
                      ",lngVoucherNOAccountID2,strVoucherFormat) VALUES (" & ID & ", '" & .strVoucherTypeCode & _
                      "','" & .strVoucherTypeName & "'," & IIf(.blnIsInActive, 1, 0) & "," & _
                      .lngDebitAccountID1 & "," & .lngDebitAccountID2 & "," & _
                      .lngCreditAccountID1 & "," & .lngCreditAccountID2 & "," & _
                      .lngVoucherAccountID1 & "," & .lngVoucherAccountID2 & "," & _
                      .lngVoucherNoAccountID1 & "," & .lngVoucherNoAccountID2 & _
                       ",'" & cboModal.ListIndex & "')" '插入数据库记录
         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=" & .lngVoucherNoAccountID2 & _
                      ",strVoucherFormat='" & cboModal.ListIndex & _
                      "' 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
    
    If mblnIsCancel = True Then Exit Sub
    If mblnIsAdd = True Then Exit Sub
    mblnIsExist = True
    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
           settlistbox lstAccount(0), 0
           settlistbox lstAccount(1), 1
           settlistbox lstAccount(2), 2
           settlistbox lstAccount(3), 3
           settlistbox lstAccount(4), 4
           settlistbox lstAccount(5), 5
           settlistbox lstAccount(6), 6
           settlistbox lstAccount(7), 7
        Else
           If lngID = 0 Then
              lstAccount(Index).Text = ""
              mstrListTextBuffer(Index) = ""
              lstAccount(Index).SetFocus
              mblnIsExist = False
              Exit Sub
           Else
              lstAccount(Index).Text = ""
              mstrListTextBuffer(Index) = ""
              lstAccount(Index).SeekId lngID
              mblnIsExist = False
              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)
'        mstrListTextBuffer(Index) = ""
        lstAccount(Index).SetFocus
    End If
    mblnIsExist = False
End Sub
Private Sub lstAccount_KeyPress(Index As Integer, KeyAscii As Integer)
    mblnIsChanged = True
    If lstAccount(Index).Text = "" Then mlngListIDBuffer(Index) = 0
    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
End Sub

Private Sub lstAccount_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Trim(lstAccount(Index).Text) <> "" Then BKKEY lstAccount(Index).hwnd, vbKeyTab
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)
    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)
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