frmentrytypecard.frm

金算盘软件代码

               If Not blnFromList Then gclsSys.SendMessage CStr(Me.hwnd), Message.msgVoucherType
            End If
    recSelect.Close
End Function

'判断记录是否被使用（可能有多张表会使用此编码）
Private Function CodeUsed(lngID As Long) As Boolean
    CodeUsed = True
    If CheckIDUsed("Voucher", "lngVoucherTypeID", lngID) Then Exit Function
    If CheckIDUsed("FixedMethod", "lngVoucherTypeID", lngID) Then Exit Function
    If CheckIDUsed("TransVoucher", "lngvouchertypeid", lngID) Then Exit Function
    CodeUsed = False
End Function


Private Sub chkPause_Click()
 mblnIsChanged = True
End Sub

Private Sub chkPause_LostFocus()
    mblnIsChanged = True
End Sub

Private Sub cmdOKCancel_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Index = 1 Then Unload Me
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
   frmMain.mnuEditShowList.Enabled = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim i As Integer
    
    mblnIsRefer = False
    If KeyCode = vbKeyEscape Or KeyCode = vbKeyReturn Then
        For i = 0 To 7
            If lstAccount(i).ReferVisible Then mblnIsRefer = True
        Next i
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn Then
        If Not mblnIsRefer Then
            BKKEY Me.ActiveControl.hwnd, vbKeyTab
        End If
    ElseIf KeyAscii = vbKeyEscape Then
'        If Not mblnIsRefer Then
'            cmdOKCancel(1).Value = True
'            KeyAscii = 0
'        End If
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOKCancel(0).Value = True
    ElseIf KeyCode = vbKeyEscape Then
        If Not mblnIsRefer Then
            cmdOKCancel(1).Value = True
            KeyCode = 0
        End If
    End If
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    Utility.LoadFormResPicture Me
    cboModal.Clear
    cboModal.AddItem "记帐凭证"
    cboModal.AddItem "收款凭证"
    cboModal.AddItem "付款凭证"
    cboModal.ListIndex = 0
'    SendKeys "%{C}"
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer
    
    If UnloadMode = vbFormControlMenu Then
       If mblnIsChanged = True Then
          intMsgReturn = ShowMsg(0, "当前凭证类型已被修改，是否保存？", _
                  vbQuestion + vbYesNoCancel + MB_TASKMODAL, Me.Caption)
          If intMsgReturn = vbYes Then
             Cancel = Not SaveCard(True)
          ElseIf intMsgReturn = vbCancel Then
             Cancel = True
          End If
       End If
    End If
    If Not Cancel Then mblnIsChanged = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Utility.UnLoadFormResPicture Me
    mblnIsCancel = False
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 150, 190, 6045, 3545
    FrameBox Me.hwnd, 270, 930, 3045, 2045
    FrameBox Me.hwnd, 3150, 930, 5925, 2045
    FrameBox Me.hwnd, 270, 2285, 3045, 3380
    FrameBox Me.hwnd, 3150, 2285, 5925, 3380
End Sub

Private Sub lstAccount_AddNew(Index As Integer)
      Dim lngID As Long
        
        mblnIsAdd = True
        lngID = mlngListIDBuffer(Index)
        lstAccount(Index).Text = mstrListTextBuffer(Index)
        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
              mblnIsAdd = False
              Exit Sub
           Else
              lstAccount(Index).Text = ""
              mstrListTextBuffer(Index) = ""
              lstAccount(Index).SeekId lngID
              mblnIsAdd = False
              lstAccount(Index).SetFocus
              Exit Sub
           End If
        End If
        lstAccount(Index).SeekId mlngListIDBuffer(Index)
        lstAccount(Index).SetFocus
        mblnIsAdd = False
End Sub

Private Sub lstAccount_Delete(Index As Integer)
    Dim blnDel As Boolean
    
    'mblnIsEditAdd = True
    blnDel = Card.DelCard(Message.msgAccount, mlngListIDBuffer(Index), frmEntryTypeCard.hwnd)
    If blnDel = True Then
       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
       lstAccount(Index).Text = ""
       mstrListTextBuffer(Index) = ""
       lstAccount(Index).SetFocus
    Else
       lstAccount(Index).SeekId mlngListIDBuffer(Index)
    End If
End Sub

Private Sub lstAccount_Edit(Index As Integer)
      '  mblnIsEditAdd = True
        If mlngListIDBuffer(Index) = 0 Then
           lstAccount(Index).Text = ""
           ShowMsg 0, "当前没有记录，不能修改！", vbExclamation + MB_TASKMODAL, Me.Caption
           Exit Sub
        End If
        lstAccount(Index).SeekId mlngListIDBuffer(Index)
        Card.EditCard Message.msgAccount, mlngListIDBuffer(Index)
        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
        lstAccount(Index).SeekId mlngListIDBuffer(Index)
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstAccount_GotFocus(Index As Integer)
   If mblnAddRecord Then
       cmdOKCancel(2).Default = False
    Else
       cmdOKCancel(0).Default = False
    End If
   If lstAccount(Index).Referrows <= 1 Then
       settlistbox lstAccount(Index), Index
   End If
End Sub

'设置列表框选项
Public Sub settlistbox(lstSetting As ListText, Index As Integer)
    Dim strSQL As String
    
     With mvcrVoucherType
        Select Case Index
            Case 0
                setlistbox lstSetting, 0, .lngDebitAccountID1
            Case 1
                setlistbox lstSetting, 0, .lngDebitAccountID2
            Case 2
                setlistbox lstSetting, 0, .lngCreditAccountID1
            Case 3
                setlistbox lstSetting, 0, .lngCreditAccountID2
            Case 4
                setlistbox lstSetting, 0, .lngVoucherAccountID1
            Case 5
                setlistbox lstSetting, 0, .lngVoucherAccountID2
            Case 6
                setlistbox lstSetting, 0, .lngVoucherNoAccountID1
            Case 7
                setlistbox lstSetting, 0, .lngVoucherNoAccountID2
        End Select
    End With

End Sub

Private Sub InputAgain()
    txtInput(0).SelStart = 0
    txtInput(0).SelLength = StrLen(txtInput(0).Text)
    txtInput(0).SetFocus
End Sub

'根据列表框选择结果来调用卡片或存储调用卡片的参数
Private Sub lstAccount_Choose(Index As Integer)
        mlngListIDBuffer(Index) = lstAccount(Index).ID
        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 cmdokcancel_Click(Index As Integer)
    Dim strSQL As String
    Dim recType As rdoResultset
    
    If mblnIsExist Then Exit Sub
    Select Case Index
        Case 0
            If SaveCard(True) Then
'               strSql = "select * from VoucherType order by lngVoucherTypeID"
'               Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'               If recType.RowCount > 0 Then
'                  recType.MoveLast
'                  ID = recType!lngVoucherTypeID
'               Else
'                  ID = 0
'               End If
               Unload Me
            End If
        Case 1    '取消
            Unload Me
        Case 2    '下一个
            SaveCard False
    End Select
End Sub

'通过事务处理完成对数据库的操作
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function SaveCard(blnClickOK As Boolean, Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim intMsgReturn As Integer
    Dim intCounter As Integer
    
    SaveCard = False
    If mblnIsExist Then Exit Function
    If Not mblnAddRecord And mblnUsed Then
        If mintModal = 0 Then
            If cboModal.ListIndex <> 0 Then
                ShowMsg Me.hwnd, "该凭证类型已经被使用，凭证格式不能改变。", vbExclamation, Caption
                cboModal.ListIndex = 0
                cboModal.SetFocus
                Exit Function
            End If
        Else
            If cboModal.ListIndex <> mintModal And cboModal.ListIndex <> 0 Then
                ShowMsg Me.hwnd, "该凭证类型已经被使用，凭证格式只能改变为记帐凭证。", vbExclamation, Caption
                cboModal.ListIndex = mintModal
                cboModal.SetFocus
                Exit Function
            End If
        End If
    End If
    If validityCheck(blnByAdd) Then  '检查数据的有效性并整理记录值成功
        gclsBase.BaseWorkSpace.BeginTrans
        If ExecBuffer Then  '修改数据库成功
            gclsBase.BaseWorkSpace.CommitTrans
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgVoucherType
            SaveCard = True
            If Not blnClickOK Then
                InitAddCard '为新增记录作设置
                InputAgain
            Else
                For intCounter = 0 To 3
                     mlngListIDBuffer(intCounter) = 0
                Next intCounter
            End If
        Else '修改数据库不成功
            gclsBase.BaseWorkSpace.RollBacktrans