frmbuyticket.frm

金算盘软件代码

    dtmInput.Text = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    lstInput(1).SeekId gclsBase.NaturalCurId
    lstInput(2).SeekId gclsBase.OperatorID
    txtInput(0).Text = ""
    txtInput(1).Text = ""
    chkVoid.Value = 0
    m_lngID = 0
    On Error Resume Next
    lstInput(0).SetFocus
End Sub
Private Sub ShowOldCard()
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    strSql = "SELECT * FROM Check1 WHERE ROWNUM<=1 AND Check1.lngActivityID=" & m_lngID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTmp
        If .BOF And .EOF Then
            ClearCard
        Else
            lstInput(0).SeekId !lngAccountID
            lstInput(1).SeekId !lngCurrencyID
            lstInput(3).SeekId !lngPaymentMethodID
            lstInput(2).Text = !strBuyer
            dtmInput.Text = !strDate
            m_OldCheckNO1 = !strCheckNo1
            m_OldCheckNO2 = !strCheckNo2
            txtInput(0).Text = m_OldCheckNO1
            txtInput(1).Text = m_OldCheckNO2
        End If
    End With
    recTmp.Close
    strSql = "SELECT lngActivityDetailID FROM CheckDetail WHERE ROWNUM<=1 " & _
        " AND lngAccountID=" & lstInput(0).ID & _
        " AND lngCurrencyID=" & lstInput(1).ID & _
        " AND lngPaymentMethodID=" & lstInput(3).ID & _
        " AND strCheckNO>='" & txtInput(0).Text & "'" & _
        " AND strCheckNO<='" & txtInput(1).Text & "'"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTmp
        If Not (.BOF And .EOF) Then
            lstInput(0).Enabled = False
            lstInput(1).Enabled = False
            lstInput(3).Enabled = False
        End If
    End With
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    On Error Resume Next
    lstInput(0).SetFocus
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.UnLoadFormResPicture Me
End Sub

Private Sub lstInput_AddNew(Index As Integer)
    Dim lngResult As Long
    
    If lstInput(Index).ID = 0 Then
        lngResult = AddCard(C2lng(lstInput(Index).Tag), lstInput(Index).Text)
    Else
        lngResult = AddCard(C2lng(lstInput(Index).Tag))
    End If
    If lngResult = 0 Then
        lngResult = lstInput(Index).ID
    End If
    GetList Index
    If lngResult <> 0 Then
        lstInput(Index).SeekId lngResult
    End If
End Sub

Private Sub lstInput_Change(Index As Integer)
    If Index <> 2 Then
        Exit Sub
    End If
    If Card.ContainErrorChar(lstInput(Index).Text, "'""") Then
        Beep
        BKKEY lstInput(Index).hwnd
    End If
End Sub

Private Sub lstInput_Delete(Index As Integer)
    If lstInput(Index).ID = 0 Then
    Else
        If DelCard(C2lng(lstInput(Index).Tag), lstInput(Index).ID, Me.hwnd) = True Then
            GetList Index
        Else
            lstInput(Index).SeekId lstInput(Index).ID
        End If
    End If
End Sub

Private Sub lstInput_Edit(Index As Integer)
    Dim lngIDBak As Long
    
    lngIDBak = lstInput(Index).ID
    If lngIDBak <> 0 Then
        EditCard C2lng(lstInput(Index).Tag), lngIDBak
        GetList Index
        lstInput(Index).SeekId lngIDBak
    End If
End Sub


Private Sub IMsgBox(ByVal strText As String, Optional ByVal strTitle As String = "提示信息")
    ShowMsg Me.hwnd, strText, MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, strTitle
End Sub

Private Function QMsgBox(ByVal strText As String, Optional ByVal strTitle As String = "提示信息", Optional ByVal blnDefButton2 As Boolean = True) As Long
    If blnDefButton2 Then
        QMsgBox = ShowMsg(Me.hwnd, strText, MB_YESNO + MB_DEFBUTTON2 + MB_ICONQUESTION + MB_SYSTEMMODAL, strTitle)
    Else
        QMsgBox = ShowMsg(Me.hwnd, strText, MB_YESNO + MB_DEFBUTTON1 + MB_ICONQUESTION + MB_SYSTEMMODAL, strTitle)
    End If
End Function

Private Sub lstInput_ItemNotExist(Index As Integer)
    Dim lngID As Long
    Dim strTitle As String
    
    If lstInput(Index).Visible = False Or lstInput(Index).Enabled = False Then
        Exit Sub
    End If
    lstInput(Index).Text = Trim(lstInput(Index).Text)
    If lstInput(Index).Text = "" Then
        Exit Sub
    End If
    
    Select Case Index
    Case 0
        strTitle = "会计科目"
    Case 1
        strTitle = "币种"
    Case 3
        strTitle = "票据种类"
    Case Else
        Exit Sub
    End Select
    
    If QMsgBox(strTitle & "中没有（" & lstInput(Index).Text & "），您是否需要新增？", , False) = vbNo Then
        lstInput(Index).Text = ""
        Exit Sub
    End If
EndProc:
    lngID = AddCard(C2lng(lstInput(Index).Tag), lstInput(Index).Text)
    If lngID <> 0 Then
        GetList Index
        lstInput(Index).SeekId lngID
    End If
End Sub

Private Sub txtInput_Change(Index As Integer)
    If Card.ContainErrorChar(txtInput(Index).Text, "`~!@#$^&*=+'"";:,./?|\") Then
        BKKEY txtInput(Index).hwnd
        Beep
    End If
End Sub
Private Function DataValid() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    On Error Resume Next
    If lstInput(0).ID <= 0 Then
        IMsgBox "银行科目为必输项，不能为空！", "保存卡片"
        lstInput(0).SetFocus
        GoTo EndProc
    End If
    If lstInput(1).ID <= 0 Then
        IMsgBox "币种为必输项，不能为空！", "保存卡片"
        lstInput(1).SetFocus
        GoTo EndProc
    End If
    lstInput(2).Text = Trim(lstInput(2).Text)
    If lstInput(2).Text = "" Then
        IMsgBox "购买人为必输项，不能为空！", "保存卡片"
        lstInput(2).SetFocus
        GoTo EndProc
    End If
    If Card.ContainErrorChar(lstInput(2).Text, "'""") Then
        IMsgBox "购买人含有非法字符，不能存盘！", "保存卡片"
        lstInput(2).SetFocus
        GoTo EndProc
    End If
    If lstInput(3).ID <= 0 Then
        IMsgBox "票据种类为必输项，不能为空！", "保存卡片"
        lstInput(3).SetFocus
        GoTo EndProc
    End If
    If Not IsDate(dtmInput.Text) Then
        IMsgBox "购买日期不是日期格式，不能存盘！", "保存卡片"
        dtmInput.SetFocus
        GoTo EndProc
    End If
    dtmInput.Text = Format(C2Date(dtmInput.Text), "YYYY-MM-DD")
    txtInput(0).Text = strLeft(Trim(txtInput(0).Text), 16)
    If txtInput(0).Text = "" Then
        IMsgBox "票据起号为必输项，不能为空！", "保存卡片"
        txtInput(0).SetFocus
        GoTo EndProc
    End If
    If Card.ContainErrorChar(txtInput(0).Text, "`~!@#$^&*=+'"";:,./?|\") Then
        IMsgBox "票据起号含有非法字符，不能存盘！", "保存卡片"
        txtInput(0).SetFocus
        GoTo EndProc
    End If
    txtInput(1).Text = strLeft(Trim(txtInput(1).Text), 16)
    txtInput(1).Text = strLeft(Trim(txtInput(1).Text), 16)
    If txtInput(1).Text = "" Then
        IMsgBox "票据止号为必输项，不能为空！", "保存卡片"
        txtInput(1).SetFocus
        GoTo EndProc
    End If
    If Card.ContainErrorChar(txtInput(1).Text, "`~!@#$^&*=+'"";:,./?|\") Then
        IMsgBox "票据止号含有非法字符，不能存盘！", "保存卡片"
        txtInput(1).SetFocus
        GoTo EndProc
    End If
    If Len(txtInput(0).Text) <> Len(txtInput(1).Text) Then
        IMsgBox "票据止号与票据起号的长度必须相同！", "保存卡片"
        txtInput(1).SetFocus
        GoTo EndProc
    End If

    If txtInput(0).Text > txtInput(1).Text Then
        IMsgBox "票据止号不能小于票据起号！", "保存卡片"
        txtInput(1).Text = txtInput(0).Text
        txtInput(1).SetFocus
        GoTo EndProc
    End If
    strSql = "SELECT strCheckNo1,strCheckNo2 FROM Check1  WHERE ROWNUM<=1 " & _
        " AND lngAccountID=" & lstInput(0).ID & _
        " AND lngCurrencyID=" & lstInput(1).ID & _
        " AND lngPaymentMethodID=" & lstInput(3).ID & _
        " AND Length(strCheckNo1)=" & Len(txtInput(0).Text) & _
        " AND ((strCheckNo1<='" & txtInput(0).Text & "' AND strCheckNo2>='" & txtInput(0).Text & "') " & _
        " OR (strCheckNo1<='" & txtInput(1).Text & "' AND strCheckNo2>='" & txtInput(1).Text & "')" & _
        " OR (strCheckNo1>='" & txtInput(0).Text & "' AND strCheckNo2<='" & txtInput(1).Text & "'))"
    If m_lngID <> 0 Then
        strSql = strSql & " AND lngActivityID<>" & m_lngID
    End If
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not (recTmp.BOF And recTmp.EOF) Then
        IMsgBox recTmp!strCheckNo1 & "至" & recTmp!strCheckNo2 & "之间的票据已经购买，不能存盘！", "保存卡片"
        txtInput(0).SetFocus
        GoTo EndProc
    End If
    recTmp.Close
    If m_lngID > 0 Then
        strSql = "SELECT strCheckNo FROM CheckDetail WHERE ROWNUM<=1 " & _
            " AND lngAccountID=" & lstInput(0).ID & _
            " AND lngCurrencyID=" & lstInput(1).ID & _
            " AND lngPaymentMethodID=" & lstInput(3).ID & _
            " AND Length(strCheckNo)=" & Len(m_OldCheckNO2) & " AND strCheckNO>='" & m_OldCheckNO1 & "'" & _
            " AND strCheckNO<='" & m_OldCheckNO2 & "'" & _
            " AND (strCheckNO<'" & txtInput(0).Text & "'" & _
            " OR strCheckNO>'" & txtInput(1).Text & "')"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not (recTmp.BOF And recTmp.EOF) Then
            IMsgBox recTmp!strCheckNo & "号票据已经领用，起止号必须包括该票据！", "保存卡片"
            If recTmp!strCheckNo < txtInput(0).Text Then
                txtInput(0).Text = recTmp!strCheckNo
                txtInput(0).SetFocus
            ElseIf recTmp!strCheckNo > txtInput(1).Text Then
                txtInput(1).Text = recTmp!strCheckNo
                txtInput(1).SetFocus
            End If
            GoTo EndProc
        End If
        recTmp.Close
    End If
    strSql = "SELECT blnIsInActive FROM Currencys WHERE ROWNUM<=1 AND lngCurrencyID=" & lstInput(1).ID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        IMsgBox "币种（" & lstInput(1).Text & "）已经被删除，不能存盘！", "保存卡片"
        GetList 1
        lstInput(1).SetFocus
        GoTo EndProc
    ElseIf recTmp!blnIsInActive <> 0 Then
        IMsgBox "币种（" & lstInput(1).Text & "）已经停用，不能存盘！", "保存卡片"
        GetList 1
        lstInput(1).SetFocus
        GoTo EndProc
    End If
    recTmp.Close
    strSql = "SELECT blnIsInActive,blnIsCheck FROM PaymentMethod WHERE ROWNUM<=1 AND lngPaymentMethodID=" & lstInput(3).ID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        IMsgBox "票据种类（" & lstInput(3).Text & "）已经被删除，不能存盘！", "保存卡片"
        GetList 3
        lstInput(3).SetFocus
        GoTo EndProc
    ElseIf recTmp!blnIsInActive <> 0 Then
        IMsgBox "票据种类（" & lstInput(3).Text & "）已经停用，不能存盘！", "保存卡片"
        GetList 3
        lstInput(3).SetFocus
        GoTo EndProc
    ElseIf recTmp!blnIsCheck = 0 Then
        IMsgBox "票据种类（" & lstInput(3).Text & "）不能进行票据管理，不能存盘！", "保存卡片"
        GetList 3
        lstInput(3).SetFocus
        GoTo EndProc
    End If
    recTmp.Close
    strSql = "SELECT lngAccountNatureID,blnIsInActive,blnIsDetail,blnIsAllCurrency,blnIsMultCurrency " & _
        " FROM Account WHERE lngAccountID=" & lstInput(0).ID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTmp
        If .BOF And .EOF Then
            IMsgBox "科目（" & lstInput(0).Text & "）已经被删除，不能存盘！", "保存卡片"
            GetList 0
            lstInput(0).SetFocus
            GoTo EndProc
        End If
        If !lngAccountNatureID <> 2 Then
            IMsgBox "科目（" & lstInput(0).Text & "）不是银行性质的科目，不能存盘！", "保存卡片"
            lstInput(0).SetFocus
            GoTo EndProc
        End If
        If !blnIsInActive <> 0 Then
            IMsgBox "科目（" & lstInput(0).Text & "）已经停用，不能存盘！", "保存卡片"
            lstInput(0).SetFocus
            GoTo EndProc
        End If
        If !blnIsDetail = 0 Then
            IMsgBox "科目（" & lstInput(0).Text & "）不是末级，不能存盘！", "保存卡片"
            lstInput(0).SetFocus
            GoTo EndProc
        End If
        If !blnIsAllCurrency <> 0 Then
        Else
            If !blnIsMultCurrency = 0 Then
                If lstInput(1).ID <> gclsBase.NaturalCurId Then
                    lstInput(1).SeekId gclsBase.NaturalCurId
                    IMsgBox "科目（" & lstInput(0).Text & "）不能核算多币种！", "保存卡片"
                    lstInput(1).SetFocus
                    GoTo EndProc
                End If
            Else
                recTmp.Close
                strSql = "SELECT lngAccountID FROM AccountCurrency " & _
                    " WHERE ROWNUM<=1 AND lngAccountID=" & lstInput(0).ID & " AND lngCurrencyID=" & lstInput(1).ID
                Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
                If recTmp.BOF And recTmp.EOF Then
                    IMsgBox "科目（" & lstInput(0).Text & "）不能核算币种（" & lstInput(1).Text & "）！", "保存卡片"
                    lstInput(1).SetFocus
                    GoTo EndProc
                End If
            End If
        End If
    End With
    DataValid = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function

Private Function SaveCard() As Boolean
    If DataValid() = False Then
        Exit Function
    End If
    If m_lngID = 0 Then
        SaveCard = SaveNewCard()
    Else
        SaveCard = SaveModifyCard()
    End If
    If SaveCard = True Then
        gclsSys.SendMessage 0, msgRCheckBuy
    End If
End Function

Private Function SaveNewCard() As Boolean
    Dim strSql As String
    
    m_lngID = GetNewID("Check1")
    strSql = "INSERT INTO Check1 (lngActivityID,lngAccountID,lngCurrencyID,lngPaymentMethodID," & _
        "strCheckNo1,strCheckNo2,strDate,strBuyer) Values (" & m_lngID & "," & _
        lstInput(0).ID & "," & lstInput(1).ID & "," & lstInput(3).ID & ",'" & _
        strLeft(txtInput(0).Text, 16) & "','" & strLeft(txtInput(1).Text, 16) & "','" & _
        dtmInput.Text & "','" & strLeft(lstInput(2).Text, 10) & "')"
    If gclsBase.ExecSQL(strSql) = True Then
        SaveNewCard = True
    Else
        m_lngID = 0
    End If
End Function

Private Function SaveModifyCard() As Boolean
    Dim strSql As String
    
    strSql = "UPDATE Check1 SET lngAccountID=" & lstInput(0).ID & _
        " ,lngCurrencyID=" & lstInput(1).ID & _
        " ,lngPaymentMethodID=" & lstInput(3).ID & _
        " ,strCheckNo1='" & strLeft(txtInput(0).Text, 16) & _
        "' ,strCheckNo2='" & strLeft(txtInput(1).Text, 16) & _
        "' ,strDate='" & dtmInput.Text & _
        "' ,strBuyer='" & strLeft(lstInput(2).Text, 10) & _
        "' WHERE lngActivityID=" & m_lngID
        
    If gclsBase.ExecSQL(strSql) = True Then
        SaveModifyCard = True
    End If
End Function