frmaddcashitem.frm

金算盘软件代码

VERSION 5.00
Begin VB.Form frmAddCashItem 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "现金流量项目"
   ClientHeight    =   2235
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5775
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2235
   ScaleWidth      =   5775
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.Frame Frame1 
      Caption         =   "现金流向"
      Height          =   735
      Left            =   120
      TabIndex        =   6
      Top             =   1320
      Width           =   4095
      Begin VB.OptionButton OptInOut 
         Caption         =   "流出"
         Height          =   255
         Index           =   1
         Left            =   2520
         TabIndex        =   8
         Top             =   360
         Width           =   1335
      End
      Begin VB.OptionButton OptInOut 
         Caption         =   "流入"
         Height          =   255
         Index           =   0
         Left            =   480
         TabIndex        =   7
         Top             =   360
         Value           =   -1  'True
         Width           =   1095
      End
   End
   Begin VB.TextBox txtCashItemNo 
      Height          =   270
      Left            =   1320
      MaxLength       =   50
      TabIndex        =   3
      Top             =   600
      Width           =   2895
   End
   Begin VB.CommandButton cmdNew 
      Height          =   345
      Left            =   4440
      Picture         =   "frmAddCashItem.frx":0000
      Style           =   1  'Graphical
      TabIndex        =   11
      Top             =   1080
      Width           =   1245
   End
   Begin VB.CommandButton cmdOK 
      CausesValidation=   0   'False
      Height          =   345
      Left            =   4440
      Picture         =   "frmAddCashItem.frx":08C2
      Style           =   1  'Graphical
      TabIndex        =   9
      Top             =   120
      Width           =   1245
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   345
      Left            =   4440
      Picture         =   "frmAddCashItem.frx":0B84
      Style           =   1  'Graphical
      TabIndex        =   10
      Top             =   600
      Width           =   1245
   End
   Begin VB.TextBox txtCashItem 
      Height          =   270
      Left            =   1320
      MaxLength       =   250
      TabIndex        =   5
      Top             =   960
      Width           =   2895
   End
   Begin VB.ComboBox cboCashType 
      Height          =   300
      Left            =   1320
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   120
      Width           =   2895
   End
   Begin VB.Label Label3 
      Caption         =   "项目编号(&B)"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   600
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "项目名称(&N)"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   960
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "项目大类(&T)"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   180
      Width           =   1095
   End
End
Attribute VB_Name = "frmAddCashItem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'新增现金流量项目 卡片
'作者：胡虎
'日期：1999-9-22

Private mblnNew As Boolean
Private mblnChanged As Boolean  '数据有变化
Private mlngID As Long          '当前卡片对应ID

Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0) As Long
    mblnNew = True
    ShowAddCashItem strName, 0
    AddCard = mlngID
End Function

Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0)
    mblnNew = False
    cmdNew.Visible = False
    ShowAddCashItem , lngID
End Sub

Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0) As Boolean
    DelCard = DeleteCashItem(lngID)
End Function

Private Sub CmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdNew_Click()
    If SaveData(IIf(mblnNew, 0, mlngID), txtCashItem.Text, txtCashItemNo.Text, cboCashType.ListIndex + 1, IIf(OptInOut(0).Value, 1, 2)) Then
        mblnChanged = True
    End If
    LoadData 0
    cboCashType.SetFocus
End Sub

Private Sub cmdOK_Click()
    If SaveData(IIf(mblnNew, 0, mlngID), txtCashItem.Text, txtCashItemNo.Text, cboCashType.ListIndex + 1, IIf(OptInOut(0).Value, 1, 2)) Then
        mblnChanged = True
        Unload Me
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then
        cmdCancel.Value = True
    ElseIf KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOK.Value = True
    End If
End Sub

Private Sub Form_Load()
    With cboCashType
        .AddItem "经营活动产生的现金流量"
        .AddItem "投资活动产生的现金流量"
        .AddItem "筹资活动产生的现金流量"
        
        .ListIndex = 0
    End With
    mblnChanged = False
End Sub

Private Function LoadData(ByVal lngID As Long, Optional ByVal strName As String)
    txtCashItem.Text = ""
    txtCashItemNo.Text = strName
    If cboCashType.ListIndex = -1 Then
        cboCashType.ListIndex = 0
    End If
    
    If lngID <> 0 Then
        Dim strSql As String
        Dim rec As rdoResultset
    
        strSql = "SELECT * FROM CashItem WHERE lngCashItemID=" & lngID
        Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        
        If Not rec.EOF Then
            txtCashItem.Text = rec!strCashItemName
            txtCashItemNo.Text = rec!strCashItemCode
            cboCashType.ListIndex = rec!lngCashItemType - 1
            If rec!lngCashFlowType = 1 Then
                OptInOut(0).Value = True
                OptInOut(1).Value = False
            Else
                OptInOut(1).Value = True
                OptInOut(0).Value = False
            End If
            mlngID = lngID
        End If
        rec.Close
        Set rec = Nothing
    End If
End Function

' 外部接口，修改指定编号内容,否则为增加，返回值表示是否数据有变化
Public Function ShowAddCashItem(Optional ByVal strName As String = "", Optional ByVal lngID As Long = 0) As Long
    mblnChanged = False
    mlngID = lngID
    LoadData lngID
    Me.Show vbModal
    ShowAddCashItem = mlngID
End Function

' 外部接口，删除指定编号的现金流量项目
Public Function DeleteCashItem(ByVal lngID As Long) As Boolean
    Dim strSql As String
    Dim rec As rdoResultset
    
    strSql = "SELECT * FROM CashItem WHERE lngCashItemID=" & lngID
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not rec.EOF Then
        If ShowMsg(0, "确实要删除现金流量项目“" & rec!strCashItemName & "”吗？", vbYesNo + MB_TASKMODAL, Caption) = vbNo Then
            rec.Close
            DeleteCashItem = False
            Exit Function
        End If
    Else
        DeleteCashItem = True
        rec.Close
        Exit Function
    End If
    
    strSql = "SELECT VoucherCashFlow.lngCashItemID, CashItem.strCashItemName " & _
        "FROM VoucherCashFlow,CashItem WHERE " & _
        "VoucherCashFlow.lngCashItemID = CashItem.lngCashItemID " & _
        "AND VoucherCashFlow.lngCashItemID=" & lngID

    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not rec.EOF Then
        ShowMsg 0, "指定的现金流量项目“" & rec!strCashItemName & "”已经被使用，不能删除？", vbExclamation + MB_TASKMODAL, Caption
        rec.Close
        Exit Function
'            Exit Function
'        '删除现金流量分割纪录
'        strSql = "DELETE FROM VoucherCashFlow WHERE lngCashItemID=" & lngID
'        gclsBase.BaseDB.Execute strSql
    End If
    rec.Close
    Set rec = Nothing
    '删除现金流量项目
    strSql = "DELETE FROM CashItem WHERE lngCashItemID=" & lngID
    gclsBase.BaseDB.Execute strSql
    
    DeleteCashItem = True
    gclsSys.SendMessage Me.hwnd, Message.msgCashFlow
End Function

' 保存指定数据，如果lngID =0 表示新增加，否则为修改
Private Function SaveData(ByVal lngID As Long, ByVal strName As String, _
    ByVal strNo As String, _
    ByVal lngItemType As Long, ByVal lngCashType As Long) As Boolean
    Dim strSql As String
    Dim rec As rdoResultset
    
    If strName = "" Then
        MsgBox "现金流量项目名称不允许为空！", vbExclamation
        
        txtCashItem.SetFocus
        Exit Function
    End If
    
    If strNo = "" Then
        MsgBox "现金流量项目编号不允许为空！", vbExclamation
        
        txtCashItemNo.SetFocus
        Exit Function
    End If
    
    strSql = "SELECT lngCashItemID FROM CashItem WHERE strCashItemCode='" & strNo & "' AND lngCashItemID<>" & lngID
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not rec.EOF Then
        MsgBox "指定的现金流量项目编号 " & strNo & " 已经存在，请重新指定！", vbExclamation
        rec.Close
        Set rec = Nothing
        
        txtCashItemNo.SetFocus
        
        Exit Function
    End If
    
    strSql = "SELECT * FROM CashItem WHERE lngCashItemID=" & lngID
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenKeyset, 4)
    
    With rec
        If .EOF Then
            mlngID = GetNewID("CashItem")
            .AddNew
            !LNGCASHITEMID = mlngID
            !strAccountList = " "
            !dblCashRate = 100
        Else
            .Edit
        End If
        !strCashItemName = strName
        !strCashItemCode = strNo
        !lngCashFlowType = lngCashType
        !lngCashItemType = lngItemType
        .Update
    End With
    rec.Close
    Set rec = Nothing
    gclsSys.SendMessage Me.hwnd, Message.msgCashFlow
    SaveData = True
End Function

Private Sub txtCashItemNo_Change()
    If Not ContainSpecifyChar(txtCashItemNo.Text) Then BKKEY txtCashItemNo.hwnd
End Sub

Private Sub txtCashItemNo_KeyPress(KeyAscii As Integer)
    If InStr("0123456789", Chr(KeyAscii)) = 0 And KeyAscii <> 8 Then KeyAscii = 0
End Sub