frmentrytypecard.frm

金算盘软件代码

   End
   Begin VB.Label lblTitle 
      Caption         =   "科目编号"
      Height          =   225
      Index           =   9
      Left            =   360
      TabIndex        =   22
      Top             =   3000
      Width           =   795
   End
   Begin VB.Label lblTitle 
      Caption         =   "科目编号"
      Height          =   225
      Index           =   10
      Left            =   3240
      TabIndex        =   21
      Top             =   1260
      Width           =   795
   End
   Begin VB.Label lblTitle 
      Caption         =   "科目编号"
      Height          =   225
      Index           =   11
      Left            =   3240
      TabIndex        =   20
      Top             =   1680
      Width           =   795
   End
   Begin VB.Label lblTitle 
      Caption         =   "科目编号"
      Height          =   225
      Index           =   6
      Left            =   360
      TabIndex        =   19
      Top             =   1260
      Width           =   795
   End
   Begin VB.Label lblTitle 
      Caption         =   "科目编号"
      Height          =   225
      Index           =   7
      Left            =   360
      TabIndex        =   18
      Top             =   1680
      Width           =   795
   End
   Begin VB.Label lblTitle 
      Caption         =   "名称(&N)"
      Height          =   225
      Index           =   4
      Left            =   2160
      TabIndex        =   2
      Top             =   390
      Width           =   645
   End
   Begin VB.Label lblTitle 
      Caption         =   "编码(&C)"
      Height          =   225
      Index           =   0
      Left            =   240
      TabIndex        =   0
      Top             =   390
      Width           =   645
   End
End
Attribute VB_Name = "frmEntryTypeCard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  凭证类型卡片
'  作者：郑权
'  日期：1998.07.21
'
'  功能：完成凭证类型表的增、删、改操作
'
'  接口： AddCard   增加凭证类型记录。
'                   参数：intModal 显示模式，strName 用户输入值
'         EditCard  修改凭证类型记录。
'                   参数： lngID 被修改的记录的ID，intModal 显示模式
'         DelCard   删除凭证类型记录。
'                   参数： lngID 被删除的记录的ID
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Type VoucherTypeRecord             '处理凭证类型表的记录
    lngVoucherTypeID As Long               '凭证类型ID
    strVoucherTypeCode As String           '凭证类型编码
    strVoucherTypeName As String           '凭证类型名称
    blnIsInActive As Boolean               '封存标志
    lngDebitAccountID1  As Long            '借方必有科目ID1
    lngDebitAccountID2 As Long             '借方必有科目ID2
    lngCreditAccountID1 As Long            '贷方必有科目ID1
    lngCreditAccountID2 As Long            '贷方必有科目ID2
    lngVoucherAccountID1  As Long          '凭证必有科目ID1
    lngVoucherAccountID2  As Long          '凭证必有科目ID2
    lngVoucherNoAccountID1 As Long         '凭证必无科目ID1
    lngVoucherNoAccountID2 As Long         '凭证必无科目ID2
End Type

'Private WithEvents mclsMainControl As MainControl '主控对象
Private mblnAddRecord As Boolean             '是增加记录还是修改记录
Private mblnIsList As Boolean
Private mblnIsExist As Boolean
Private mblnUsed As Boolean
Private mstrListTextBuffer(7) As String      '暂存列表框输入值，以备新增
Private mlngListIDBuffer(7) As Long          '暂存列表框选择的ID，以备修改或删除
Private mstrSQLBuffer() As String            '暂时存储对数据库的增删改操作
Private mintSQLIndex As Integer              'strSQLBuffer的索引
Private mvcrVoucherType As VoucherTypeRecord '暂存读写记录的数据
Private mstrInitCode As String         '暂存编码的初始值，以备判断是否修改
Private mintModal As Integer
Private mblnIsChanged As Boolean
Private mblnIsRefer As Boolean
Private ID As Long
Private mblnIsAdd As Boolean        '是否是LISTTEXT的ADDNEW方法
Private mblnIsCancel As Boolean     '是否是敲了CANCEL键

Private Function AccountValid(ByVal lngAcnID1 As Long, ByVal lngAcnID2 As Long) As Boolean
    AccountValid = False
    If lngAcnID1 <> 0 And lngAcnID2 <> 0 Then
        If lngAcnID1 = lngAcnID2 Then Exit Function
    End If
    AccountValid = True
End Function

Public Function AddVoucherType(ByVal strVoucher As String) As Integer
    Dim strVoucherTypeCode As String, strVoucherTypeName As String
    Dim blnIsInActive As Boolean, lngDebitAccountID1 As Long
    Dim lngDebitAccountID2 As Long, lngCreditAccountID1 As Long
    Dim lngCreditAccountID2 As Long, lngVoucherAccountID1 As Long
    Dim lngVoucherAccountID2 As Long, lngVoucherNoAccountID1 As Long
    Dim lngVoucherNoAccountID2 As Long, strVoucherFormat As String
    Dim strTemp As String
    
    On Error GoTo ErrHandle
    AddVoucherType = 0
    If Not GetString(strVoucher, strVoucherTypeCode, 1) Then Exit Function
    If Not GetString(strVoucher, strVoucherTypeName, 2) Then Exit Function
    If Not GetString(strVoucher, strTemp, 3) Then Exit Function
    blnIsInActive = (strTemp = "1")
    If Not GetString(strVoucher, strTemp, 4) Then Exit Function
    lngDebitAccountID1 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 5) Then Exit Function
    lngDebitAccountID2 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 6) Then Exit Function
    lngCreditAccountID1 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 7) Then Exit Function
    lngCreditAccountID2 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 8) Then Exit Function
    lngVoucherAccountID1 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 9) Then Exit Function
    lngVoucherAccountID2 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 10) Then Exit Function
    lngVoucherNoAccountID1 = CLng(strTemp)
    If Not GetString(strVoucher, strTemp, 11) Then Exit Function
    lngVoucherNoAccountID2 = CLng(strTemp)
    If Not GetString(strVoucher, strVoucherFormat, 12) Then Exit Function
    
    If strVoucherTypeCode = "" Or strVoucherTypeName = "" Then Exit Function
    txtInput(0).Text = strVoucherTypeCode
    txtInput(1).Text = strVoucherTypeName
    cboModal.ListIndex = strVoucherFormat
    mvcrVoucherType.strVoucherTypeCode = strVoucherTypeCode
    mvcrVoucherType.strVoucherTypeName = strVoucherTypeName
    mvcrVoucherType.blnIsInActive = blnIsInActive
    mvcrVoucherType.lngDebitAccountID1 = lngDebitAccountID1
    mvcrVoucherType.lngDebitAccountID2 = lngDebitAccountID2
    mvcrVoucherType.lngCreditAccountID1 = lngCreditAccountID1
    mvcrVoucherType.lngCreditAccountID2 = lngCreditAccountID2
    mvcrVoucherType.lngVoucherAccountID1 = lngVoucherAccountID1
    mvcrVoucherType.lngVoucherAccountID2 = lngVoucherAccountID2
    mvcrVoucherType.lngVoucherNoAccountID1 = lngVoucherNoAccountID1
    mvcrVoucherType.lngVoucherNoAccountID2 = lngVoucherNoAccountID2
    If Not AccountValid(lngDebitAccountID1, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngDebitAccountID1, lngVoucherNoAccountID2) Then Exit Function
    If Not AccountValid(lngDebitAccountID2, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngDebitAccountID2, lngVoucherNoAccountID2) Then Exit Function
    If Not AccountValid(lngCreditAccountID1, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngCreditAccountID1, lngVoucherNoAccountID2) Then Exit Function
    If Not AccountValid(lngCreditAccountID2, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngCreditAccountID2, lngVoucherNoAccountID2) Then Exit Function
    If Not AccountValid(lngVoucherAccountID1, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngVoucherAccountID1, lngVoucherNoAccountID2) Then Exit Function
    If Not AccountValid(lngVoucherAccountID2, lngVoucherNoAccountID1) Then Exit Function
    If Not AccountValid(lngVoucherAccountID2, lngVoucherNoAccountID2) Then Exit Function
'    chkPause.Value = IIf(blnIsInActive, Checked, Unchecked)
    mblnAddRecord = True
    mintSQLIndex = 0
    If Not SaveCard(True, True) Then Exit Function
    AddVoucherType = 1
ErrHandle:
End Function

'进入新增凭证类型
Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0, _
    Optional ByVal IsList As Boolean = False) As Long
    mblnAddRecord = True
    frmEntryTypeCard.Caption = "新增凭证类型"
    cmdOKCancel(2).Visible = True
    mblnIsList = IsList
    InitAddCard strName
    Show intModal
    AddCard = ID
End Function

'初始化暂存读写记录的数据的自定义类型变量和卡片
Private Sub InitAddCard(Optional strName As String = "")
    Dim intCounter As Integer
    
    With mvcrVoucherType
        .lngVoucherTypeID = 0
        .strVoucherTypeCode = 0
        .strVoucherTypeName = ""
        .blnIsInActive = False
        .lngDebitAccountID1 = 0
        .lngDebitAccountID2 = 0
        .lngCreditAccountID1 = 0
        .lngCreditAccountID2 = 0
        .lngVoucherAccountID1 = 0
        .lngVoucherAccountID2 = 0
        .lngVoucherNoAccountID1 = 0
        .lngVoucherNoAccountID2 = 0
    End With
    mblnIsChanged = False
    If txtInput(0).Text = "Text1" Or txtInput(0).Text = "" Then
        txtInput(0).Text = ""
    Else
        txtInput(0).Text = GetNextCode(txtInput(0).Text)
        mstrInitCode = txtInput(0).Text
    End If
    txtInput(1).Text = strName
    For intCounter = 0 To 7
        lstAccount(intCounter).Text = ""
        mstrListTextBuffer(intCounter) = ""
        mlngListIDBuffer(intCounter) = 0
    Next intCounter
    mintModal = 0
    mblnUsed = False
    chkPause.Value = Unchecked
    InitBuffer '清空暂时存储数据库操作的数组
End Sub

'进入修改凭证类型
Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0)
    mblnAddRecord = False
    frmEntryTypeCard.Caption = "修改凭证类型"
    cmdOKCancel(2).Visible = False
    mblnIsChanged = False
    ID = lngID
    If Not SelectRecord(lngID) Then Exit Sub   '查找记录
    Show intModal
   End Sub

'查找出想修改的凭证类型表编码记录，存放在自定义类型变量中
Private Function SelectRecord(ByVal lngRecordID As Long) As Boolean
    Dim strSQL As String
    Dim recSelect As rdoResultset
    
    SelectRecord = False
    With mvcrVoucherType
        .lngVoucherTypeID = lngRecordID
        strSQL = "SELECT * FROM VoucherType WHERE lngVoucherTypeID=" & .lngVoucherTypeID
        Set recSelect = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        If recSelect.EOF Then
            ShowMsg 0, "当前修改的凭证类型不存在，不能修改！", _
                      vbExclamation + MB_TASKMODAL, Me.Caption
            Unload Me
            Exit Function
        End If
        .strVoucherTypeName = recSelect!strVoucherTypeName
        .strVoucherTypeCode = recSelect!strVoucherTypeCode
        .blnIsInActive = recSelect!blnIsInActive
        .lngDebitAccountID1 = recSelect!lngDebitAccountID1
        .lngDebitAccountID2 = recSelect!lngDebitAccountID2
        .lngCreditAccountID1 = recSelect!lngCreditAccountID1
        .lngCreditAccountID2 = recSelect!lngCreditAccountID2
        .lngVoucherAccountID1 = recSelect!lngVoucherAccountID1
        .lngVoucherAccountID2 = recSelect!lngVoucherAccountID2
        .lngVoucherNoAccountID1 = recSelect!lngVoucherNoAccountID1
        .lngVoucherNoAccountID2 = recSelect!lngVoucherNoAccountID2
        txtInput(0).Text = .strVoucherTypeCode
        txtInput(1).Text = .strVoucherTypeName
        mblnUsed = CodeUsed(lngRecordID)
        cboModal.ListIndex = CInt(Format(recSelect!strVoucherFormat, "@;0"))
        mintModal = cboModal.ListIndex
        If CodeUsed(lngRecordID) Then
        End If
        selectListName 0, recSelect!lngDebitAccountID1
        selectListName 1, recSelect!lngDebitAccountID2
        selectListName 2, recSelect!lngCreditAccountID1
        selectListName 3, recSelect!lngCreditAccountID2
        selectListName 4, recSelect!lngVoucherAccountID1
        selectListName 5, recSelect!lngVoucherAccountID2
        selectListName 6, recSelect!lngVoucherNoAccountID1
        selectListName 7, recSelect!lngVoucherNoAccountID2
        If recSelect!blnIsInActive = 1 Then
            chkPause.Value = Checked
        Else
            chkPause.Value = Unchecked
        End If
        InitBuffer '清空暂时存储数据库操作的数组
        recSelect.Close
    End With
    SelectRecord = True
End Function

Private Sub selectListName(Index As Integer, lngID As Long)
    Dim strSQL As String
    Dim recSetting As rdoResultset
  
    strSQL = "SELECT straccountcode,strAccountName FROM Account WHERE lngAccountID=" & lngID
    Set recSetting = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recSetting.EOF Then
       settlistbox lstAccount(Index), Index
    End If
    recSetting.Close
End Sub

'进入删除凭证类型表，判断记录是否是末级和被使用，删除记录
Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0, Optional blnFromList As Boolean = False) As Boolean
    Dim strSQL As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer
    Dim blnSQLExec As Boolean
    
    DelCard = False
    strSQL = "SELECT * FROM VoucherType WHERE lngVoucherTypeID=" & lngID
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If recSelect.EOF Then
        recSelect.Close
        Exit Function
    End If
'    If frmVoucherTypeList.IsShowCard = True Then
'       If lngID = frmVoucherTypeListCard.VoucherTypeID Then
'          ShowMsg lnghWnd, "不能删除当前正在修改的凭证类型！", _
'                    vbExclamation + MB_TASKMODAL, "删除凭证类型"
'          Exit Function
'       End If
'    End If
    If CodeUsed(lngID) Then
        intMsgReturn = ShowMsg(lnghWnd, "其它地方正在使用此凭证类型，不能删除！", _
                    vbExclamation + MB_TASKMODAL, "删除凭证类型")
    Else
        intMsgReturn = ShowMsg(lnghWnd, "你确实要删除“" & recSelect!strVoucherTypeName & "”凭证类型吗？", _
                    vbQuestion + vbOKCancel + MB_SYSTEMMODAL + vbDefaultButton2, "删除凭证类型")
        If intMsgReturn = vbOK Then
            strSQL = "DELETE FROM VoucherType  WHERE lngVoucherTypeID = " & lngID
            blnSQLExec = gclsBase.ExecSQL(strSQL)
'            If blnSQLExec Then
'               gclsSys.SendMessage CStr(Me.hwnd), Message.msgVoucherType
'            End If
        End If
    End If
    DelCard = blnSQLExec
            If blnSQLExec Then