frmvouchertypelistcard.frm

金算盘软件代码

Private Sub chkPause_LostFocus()
    mblnIsChanged = True
End Sub

Private Sub Form_Activate()
     gclsSys.CurrFormName = Me.hwnd
     frmMain.mnuEditShowList.Enabled = True
End Sub

Private Sub Form_Load()
     Utility.LoadFormResPicture Me
'    Set cmdOKCancel(0).Picture = LoadResPicture(1001, vbResBitmap)
'    Set cmdOKCancel(1).Picture = LoadResPicture(1002, vbResBitmap)
'    Set cmdOKCancel(2).Picture = LoadResPicture(1004, vbResBitmap)
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    SetHelpID Me.hwnd, 30039  '18006
    
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_Resize()
     If Me.Left + Me.Width < 0 Or Me.Left > Screen.Width Then
       Me.Left = 300
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.UnLoadFormResPicture Me
    frmVoucherTypeList.IsShowCard = False
    gclsSys.CurrFormName = ""
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 150, 140, 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
        
        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
           setlistbox lstAccount(0), 0
           setlistbox lstAccount(1), 1
           setlistbox lstAccount(2), 2
           setlistbox lstAccount(3), 3
           setlistbox lstAccount(4), 4
           setlistbox lstAccount(5), 5
           setlistbox lstAccount(6), 6
           setlistbox lstAccount(7), 7
        Else
           If lngID = 0 Then
              lstAccount(Index).Text = ""
              Exit Sub
           Else
              lstAccount(Index).SeekId lngID
              Exit Sub
           End If
        End If
        lstAccount(Index).SeekId mlngListIDBuffer(Index)
End Sub

Private Sub lstAccount_Delete(Index As Integer)
    Dim blnDel As Boolean
    
'    mblnIsEditAdd = True
    blnDel = Card.DelCard(Message.msgAccount, mlngListIDBuffer(Index), frmVoucherTypeListCard.hwnd)
    If blnDel = True Then
        setlistbox lstAccount(0), 0
        setlistbox lstAccount(1), 1
        setlistbox lstAccount(2), 2
        setlistbox lstAccount(3), 3
        setlistbox lstAccount(4), 4
        setlistbox lstAccount(5), 5
        setlistbox lstAccount(6), 6
        setlistbox lstAccount(7), 7
        lstAccount(Index).Text = ""
        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)
        setlistbox lstAccount(0), 0
        setlistbox lstAccount(1), 1
        setlistbox lstAccount(2), 2
        setlistbox lstAccount(3), 3
        setlistbox lstAccount(4), 4
        setlistbox lstAccount(5), 5
        setlistbox lstAccount(6), 6
        setlistbox 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
       setlistbox lstAccount(Index), Index
   End If
End Sub

'设置列表框选项
Public Sub setlistbox(lstSetting As ListText, Index As Integer)
    Dim strSql As String
    
     With mvcrVoucherType
        Select Case Index
            Case 0
                Card.setlistbox lstSetting, 0, .lngDebitAccountID1
            Case 1
                Card.setlistbox lstSetting, 0, .lngDebitAccountID2
            Case 2
                Card.setlistbox lstSetting, 0, .lngCreditAccountID1
            Case 3
                Card.setlistbox lstSetting, 0, .lngCreditAccountID2
            Case 4
                Card.setlistbox lstSetting, 0, .lngVoucherAccountID1
            Case 5
                Card.setlistbox lstSetting, 0, .lngVoucherAccountID2
            Case 6
                Card.setlistbox lstSetting, 0, .lngVoucherNOAccountID1
            Case 7
                Card.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
    
    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) As Boolean
    Dim intMsgReturn As Integer
    Dim intCounter As Integer
    
    SaveCard = False
    If validityCheck(blnClickOK) 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
            mblnAddRecord = True
            InitAddCard '初始化
            InputAgain
        End If
    Else '检查数据的有效性并整理记录值不成功
        InitBuffer   '清空暂时存储数据库操作的数组
    End If
End Function

'检查数据的有效性并整理记录值,存储记录
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function validityCheck(blnClickOK As Boolean) As Boolean
    Dim intMsgReturn As Integer
    Dim strSql As String
    Dim intIndex As Integer
    Dim recSelect As rdoResultset
    Dim i As Integer
    
    validityCheck = True
    If strLen(Trim(txtInput(0).Text)) = 0 Then   '检查非空项
        If blnClickOK = True Then
            intMsgReturn = ShowMsg(0, " 凭证类型编码必需输入！", _
            vbExclamation + MB_TASKMODAL, Me.Caption)
        End If
        validityCheck = False
        InputAgain
        Exit Function
    Else
       If InStr(1, txtInput(0).Text, "'") <> 0 Then
          ShowMsg 0, "凭证类型编码中不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          InputAgain
          Exit Function
       End If
    End If
    If strLen(Trim(txtInput(1).Text)) = 0 Then    '检查非空项
        If blnClickOK = True Then
            intMsgReturn = ShowMsg(0, " 凭证类型名称必需输入！", _
            vbExclamation + MB_TASKMODAL, Me.Caption)
        End If
        validityCheck = False
        txtInput(1).SelStart = 0
        txtInput(1).SelLength = strLen(txtInput(1).Text)
        txtInput(1).SetFocus
        Exit Function
    Else
        If InStr(1, txtInput(1).Text, "'") <> 0 Then
           ShowMsg 0, "凭证类型名称中不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
           validityCheck = False
           txtInput(1).SelStart = 0
           txtInput(1).SelLength = strLen(txtInput(1).Text)
           txtInput(1).SetFocus
           Exit Function
        End If
    End If