frmlendticket.frm

金算盘软件代码

                chkVoid.Value = !blnIsInActive
            End If
        End With
    End If
    ShowOldCard = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    On Error Resume Next
    If m_blnCheck = False Then
        lstInput(0).SetFocus
    Else
        curInput(1).SetFocus
    End If
End Function

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)
    Select Case Index
    Case 2, 3, 5
    Case Else
        Exit Sub
    End Select
    If Card.ContainErrorChar(lstInput(Index).Text, "'""") Then
        Beep
        BKKEY lstInput(Index).hwnd
    End If
End Sub

Private Sub LstInput_Choose(Index As Integer)
    Dim intCurrDec As Integer
    Dim intRateDec As Integer
    
    If Index = 1 Then
        If BillPublic.CurRateDec(lstInput(1).ID, intCurrDec, intRateDec) Then
            
        Else
            IMsgBox "币种（" & lstInput(1).Text & "）已经被删除，请重新选择！", "错误信息"
            GetList 1
            lstInput(1).SeekId gclsBase.NaturalCurId
            intCurrDec = gclsBase.NaturalCurDec
        End If
        curInput(0).Digits = intCurrDec
        curInput(1).Digits = intCurrDec
        curInput(0).MaxLength = intCurrDec + 13
        curInput(1).MaxLength = intCurrDec + 13
    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 4
        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 m_blnCheck = True Then
        If Not IsDate(dtmInput(1).Text) Then
            IMsgBox "报销日期不是日期格式，不能存盘！", "保存卡片"
            dtmInput(1).SetFocus
            GoTo EndProc
        End If
        dtmInput(1).Text = Format(C2Date(dtmInput(1).Text), "YYYY-MM-DD")
        
        If C2Date(dtmInput(1).Text) < C2Date(dtmInput(0).Text) Then
            IMsgBox "报销日期不能小于领用日期！", "保存卡片"
            dtmInput(1).Text = dtmInput(0).Text
            dtmInput(1).SetFocus
            GoTo EndProc
        End If
    End If
    
    If lstInput(2).Enabled = False Then
        DataValid = True
        GoTo EndProc
    End If
    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
    
    If Not IsDate(dtmInput(0).Text) Then
        IMsgBox "领用日期不是日期格式，不能存盘！", "保存卡片"
        dtmInput(0).SetFocus
        GoTo EndProc
    End If
    dtmInput(0).Text = Format(C2Date(dtmInput(0).Text), "YYYY-MM-DD")
    
    lstInput(2).Text = strLeft(Trim(lstInput(2).Text), 30)
'    If lstInput(2).Text = "" Then
'        IMsgBox "领用部门为必输项，不能为空！", "保存卡片"
'        lstInput(2).SetFocus
'        GoTo EndProc
'        lstInput(2).Text = " "
'    End If
    If Card.ContainErrorChar(lstInput(2).Text, "'""") Then
        IMsgBox "领用部门含有非法字符，不能存盘！", "保存卡片"
        lstInput(2).SetFocus
        GoTo EndProc
    End If
    
    lstInput(3).Text = strLeft(Trim(lstInput(3).Text), 10)
'    If lstInput(3).Text = "" Then
'        IMsgBox "领用人为必输项，不能为空！", "保存卡片"
'        lstInput(3).SetFocus
'        GoTo EndProc
'        lstInput(3).Text = " "
'    End If
    If Card.ContainErrorChar(lstInput(3).Text, "'""") Then
        IMsgBox "领用人含有非法字符，不能存盘！", "保存卡片"
        lstInput(3).SetFocus
        GoTo EndProc
    End If
    
    If lstInput(4).ID <= 0 Then
        IMsgBox "票据种类为必输项，不能为空！", "保存卡片"
        lstInput(4).SetFocus
        GoTo EndProc
    End If
    
    txtInput(0).Text = strLeft(Trim(txtInput(0).Text), 16)
    If txtInput(0).Text = "" Then
        IMsgBox "票据号为必输项，不能为空！", "保存卡片"
        txtInput(0).SetFocus
        GoTo EndProc
    End If
    
    txtInput(1).Text = strLeft(Trim(txtInput(1).Text), 40)
    If txtInput(1).Text = "" Then txtInput(1).Text = " "
    lstInput(5).Text = strLeft(Trim(lstInput(5).Text), 10)
    If lstInput(5).Text = "" Then
        IMsgBox "签发人为必输项，不能为空！", "保存卡片"
        lstInput(5).SetFocus
        GoTo EndProc
    End If
    If Card.ContainErrorChar(lstInput(5).Text, "'""") Then
        IMsgBox "签发人含有非法字符，不能存盘！", "保存卡片"
        lstInput(5).SetFocus
        GoTo EndProc
    End If
    
    If Card.ContainErrorChar(txtInput(0).Text, "`~!@#$^&*=+'"";:,./?|\") Then
        IMsgBox "票据号含有非法字符，不能存盘！", "保存卡片"
        txtInput(0).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(4).ID & _
        " AND (strCheckNo1<='" & txtInput(0).Text & "' AND strCheckNo2>='" & txtInput(0).Text & "') " & _
        " AND Length(strCheckNo1)=" & Len(txtInput(0).Text)     '作废标志为假
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If (recTmp.BOF And recTmp.EOF) Then
        IMsgBox txtInput(0).Text & "号票据没有购买，不能存盘！", "保存卡片"
        txtInput(0).SetFocus
        GoTo EndProc
    End If
    recTmp.Close
    strSql = "SELECT lngActivityDetailID FROM CheckDetail WHERE ROWNUM<=1 " & _
        " AND lngAccountID=" & lstInput(0).ID & _
        " AND lngCurrencyID=" & lstInput(1).ID & _
        " AND lngPaymentMethodID=" & lstInput(4).ID & _
        " AND strCheckNo='" & txtInput(0).Text & "'" & _
        " AND lngActivityDetailID<>" & m_lngID      'AND blnIsInActive=0
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not (recTmp.BOF And recTmp.EOF) Then
        IMsgBox txtInput(0).Text & "号票据已经领用，不能存盘！", "保存卡片"
        txtInput(0).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 & "）已经被删除，不能存盘！", "保存卡片"
            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_blnCheck = False Then
        If m_lngID = 0 Then
            SaveCard = SaveNewCard()
        Else
            SaveCard = SaveModifyCard()
        End If
    Else
        SaveCard = SaveCheckCard()
    End If
    If SaveCard = True Then
        gclsSys.SendMessage 0, msgRCheckUser
    End If
End Function

Private Function SaveNewCard() As Boolean
    Dim strSql As String
    
    m_lngID = GetNewID("CheckDetail")
    strSql = "INSERT INTO CheckDetail (lngActivityDetailID,lngAccountID,lngCurrencyID," & _
        "lngPaymentMethodID,strCheckNo,strOutDate,strOutDepartment,strOutMan,strRemark," & _
        "dblCurrBugetAmount,strSigner,blnIsInActive) " & _
        "Values (" & m_lngID & "," & lstInput(0).ID & "," & lstInput(1).ID & "," & _
        lstInput(4).ID & ",'" & strLeft(txtInput(0).Text, 16) & "','" & dtmInput(0).Text & "','" & _
        IIf(lstInput(2).Text = "", " ", lstInput(2).Text) & "','" & IIf(lstInput(3).Text = "", " ", lstInput(3).Text) & "','" & txtInput(1).Text & "'," & _
        C2Dbl(curInput(0).Text) & ",'" & lstInput(5).Text & "'," & chkVoid.Value & ")"
    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 CheckDetail SET lngAccountID=" & lstInput(0).ID & _
        " , lngCurrencyID=" & lstInput(1).ID & _
        " , lngPaymentMethodID=" & lstInput(4).ID & _
        " , strCheckNo='" & strLeft(txtInput(0).Text, 16) & _
        "' , strOutDate='" & dtmInput(0).Text & _
        "' , strOutDepartment='" & IIf(lstInput(2).Text = "", " ", lstInput(2).Text) & _
        "' , strOutMan='" & IIf(lstInput(3).Text = "", " ", lstInput(3).Text) & _
        "' , strRemark='" & txtInput(1).Text & _
        "' , dblCurrBugetAmount=" & C2Dbl(curInput(0).Text) & _
        " , strSigner='" & lstInput(5).Text & _
        "' , blnIsInActive=" & chkVoid.Value & _
        " WHERE lngActivityDetailID=" & m_lngID
        
    If gclsBase.ExecSQL(strSql) = True Then
        SaveModifyCard = True
    End If
End Function
Private Function SaveCheckCard() As Boolean
    Dim strSql As String
    
    strSql = "UPDATE CheckDetail SET blnIsUsed=1" & _
        " ,strUseDate='" & dtmInput(1).Text & _
        "' ,dblCurrAmount=" & C2Dbl(curInput(1).Text) & _
        " WHERE lngActivityDetailID=" & m_lngID
        
    If gclsBase.ExecSQL(strSql) = True Then
        SaveCheckCard = True
    End If
End Function