frmexpense.frm

金算盘软件代码

        If C2Dbl(spinRate1.Text) < 0 Then
            ValidAccount2 = False
            Msg = "药品支出科目分摊比例不能小于0！"
        End If
        If C2Dbl(spinRate1.Text) > 100 Then
            ValidAccount2 = False
            Msg = "药品支出科目分摊比例不能大于100！"
        End If
    End If
    If ValidAccount2 Then
        If ltxtAcc22.ID = 0 Then
'            ValidAccount2 = False
'            Msg = "输入制剂生产科目！"
        Else
            strSql = "SELECT * FROM Account WHERE lngAccountID=" & ltxtAcc22.ID
            Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recAccount.EOF Then
                If recAccount!blnIsDetail = 1 Then
                    mblnAcc22IsDetail = True
                    ValidAccount2 = False
                    Msg = "制剂生产科目必须是明细科目！"
                    If recAccount!blnIsCustomer = 1 Or recAccount!blnIsDepartment = 1 Or recAccount!blnIsEmployee = 1 Or _
                        recAccount!blnIsClass1 = 1 Or recAccount!blnIsClass2 = 1 Or _
                        recAccount!blnIsQuantity = 1 Or recAccount!blnIsMultCurrency = 1 Or recAccount!blnIsAllCurrency = 1 Then
                        ValidAccount2 = False
                        Msg = "制剂生产科目不能有辅助核算,也不能进行外币核算！"
                    ElseIf recAccount!lngAccountNatureID > 0 Then
                        ValidAccount2 = False
                        Msg = "制剂生产科目不能是现金银行、应收应付及存货类科目！"
                    End If
                End If
            Else
                ValidAccount2 = False
                Msg = "制剂生产科目不存在！"
            End If
            recAccount.Close
            Set recAccount = Nothing
        End If
    End If
    If ValidAccount2 Then
        If C2Dbl(spinRate2.Text) < 0 Then
            ValidAccount2 = False
            Msg = "制剂生产科目分摊比例不能小于0！"
        End If
        If C2Dbl(spinRate2.Text) > 100 Then
            ValidAccount2 = False
            Msg = "制剂生产科目分摊比例不能大于100！"
        End If
    End If
    fraWizard(2).Tag = ""
    If ValidAccount2 Then
        SaveSet 1, "管理费用分摊", "医疗支出科目", ltxtAcc20.ID, True, "Long"
        SaveSet 1, "管理费用分摊", "药品支出科目", ltxtAcc21.ID, True, "Long"
        SaveSet 1, "管理费用分摊", "制剂生产科目", ltxtAcc22.ID, True, "Long"
        SaveSet 1, "管理费用分摊", "医疗支出比例", C2Dbl(spinRate0.Text), True, "Double"
        SaveSet 1, "管理费用分摊", "药品支出比例", C2Dbl(spinRate1.Text), True, "Double"
        SaveSet 1, "管理费用分摊", "制剂生产比例", C2Dbl(spinRate2.Text), True, "Double"
    End If
End Function

'第三步，凭证预览
Private Function ValidResult(Msg As String) As Boolean
    ValidResult = True
    
    If ExclusiveIn(Caption, mclsMainControl.LogID) Then
        If ValidResult Then
            If ltxtTemplate.ID = 0 Then
                ValidResult = False
                Msg = "未指定凭证模板！"
            End If
        End If
        If ValidResult Then
            If ltxtType.ID = 0 Then
                ValidResult = False
                Msg = "未指定凭证类型！"
            End If
        End If
        If ValidResult Then
            VoucherData(0).TemplateID = ltxtTemplate.ID
            VoucherData(0).VoucherTypeID = ltxtType.ID
            VoucherData(1).TemplateID = ltxtTemplate.ID
            VoucherData(1).VoucherTypeID = ltxtType.ID
            VoucherData(2).TemplateID = ltxtTemplate.ID
            VoucherData(2).VoucherTypeID = ltxtType.ID
        End If
    Else
        ValidResult = False
        stabWizard.Tab = mintStepNum - 1
    End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'卡片新增（模板）
Private Sub ltxtTemplate_AddNew()
    Dim lngTemplateID As Long
    lngTemplateID = FrmNewTemplate.AddCard(, 1, 17, mlngFormatID, ltxtTemplate.ID)
    RefreshTemplate lngTemplateID
End Sub
Private Sub ltxtTemplate_Delete()
    If ltxtTemplate.ID > 0 Then
        If Card.DelCard(msgTemplate, ltxtTemplate.ID) Then
            RefreshTemplate
        Else
            ltxtTemplate.SeekId ltxtTemplate.ID
        End If
    End If
End Sub
Private Sub ltxtTemplate_Edit()
    If ltxtTemplate.ID > 0 Then
       Card.EditCard msgTemplate, ltxtTemplate.ID, , mlngFormatID
       RefreshTemplate ltxtTemplate.ID
    End If
End Sub
Private Sub ltxtTemplate_ItemNotExist()
    Dim lngID As Long
    If frmMsgAdd.MsgAddShow("增加凭证模板", "凭证模板“" & Trim(ltxtTemplate.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = FrmNewTemplate.AddCard(ltxtTemplate.Text, 1, 17, mlngFormatID, ltxtTemplate.ID)
        RefreshTemplate lngID
    Else
        ltxtTemplate.Text = ""
    End If
End Sub


'卡片新增（凭证类型）
Private Sub ltxtType_AddNew()
    Dim lngID As Long
    lngID = Card.AddCard(msgVoucherType)
    RefreshVoucherType lngID
End Sub
Private Sub ltxtType_Delete()
    If ltxtType.ID > 0 Then
        If Card.DelCard(msgVoucherType, ltxtType.ID) Then
            RefreshVoucherType
        Else
            ltxtType.SeekId ltxtType.ID
        End If
    End If
End Sub
Private Sub ltxtType_Edit()
    If ltxtType.ID > 0 Then
        Card.EditCard msgVoucherType, ltxtType.ID
        RefreshVoucherType ltxtType.ID
    End If
End Sub
Private Sub ltxtType_ItemNotExist()
    Dim lngID As Long
    
    If frmMsgAdd.MsgAddShow("增加凭证类型", "凭证类型“" & Trim(ltxtType.Text) & "”不存在，是否新增?") = vbOK Then
        lngID = Card.AddCard(msgVoucherType, ltxtType.Text)
        RefreshVoucherType lngID
    Else
        ltxtType.Text = ""
    End If
End Sub


Private Sub RefreshVoucherType(Optional ByVal lngID As Long)
    If Not ltxtType.Recordset Is Nothing Then
        Utility.RemoveListRecordSet lrtVoucherType
    End If
    On Error Resume Next
    ltxtType.ClearRefer
    Set ltxtType.Recordset = Utility.GetListRecordSet(lrtVoucherType)
    ltxtType.Comparts = 2
    ltxtType.AddRefer "<新增>"
    ltxtType.AddRefer "<修改>"
    ltxtType.AddRefer "<删除>"
    If lngID > 0 Then
        ltxtType.SeekId lngID
    Else
        If Not ltxtType.Recordset Is Nothing Then
            'ltxtType.ReferRow = 4 + IIf(ltxtType.Recordset.RecordCount > 0, ltxtType.Recordset.RecordCount - 1, 0)
            ltxtType.ReferRow = 4 + IIf(ltxtType.Recordset.RowCount > 0, ltxtType.Recordset.RowCount - 1, 0)
        Else
            ltxtType.Text = ""
        End If
    End If
End Sub

Private Sub RefreshAccount(Optional intChoice As Integer)
    Dim lngAccountID As Long
    
    If intChoice = 1 Then
        lngAccountID = ltxtAcc1.ID
        If Not ltxtAcc1.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc1.ClearRefer
        Set ltxtAcc1.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc1.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc1.SeekId lngAccountID
        End If
    End If
    If intChoice = 21 Then
        lngAccountID = ltxtAcc20.ID
        If Not ltxtAcc20.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc20.ClearRefer
        Set ltxtAcc20.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc20.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc20.SeekId lngAccountID
        End If
    End If
    If intChoice = 22 Then
        lngAccountID = ltxtAcc21.ID
        If Not ltxtAcc21.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc21.ClearRefer
        Set ltxtAcc21.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc21.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc21.SeekId lngAccountID
        End If
    End If
    If intChoice = 23 Then
        lngAccountID = ltxtAcc22.ID
        If Not ltxtAcc22.Recordset Is Nothing Then
            Utility.RemoveListRecordSet lrtAccount
        End If
        On Error Resume Next
        ltxtAcc22.ClearRefer
        Set ltxtAcc22.Recordset = Utility.GetListRecordSet(lrtAccount)
        ltxtAcc22.Comparts = 1
        If lngAccountID > 0 Then
            ltxtAcc22.SeekId lngAccountID
        End If
    End If
End Sub

Private Sub RefreshTemplate(Optional lngID As Long)
    Dim strSql As String
    Dim strCondVersion As String
    Dim recType As rdoResultset
    Dim lngFormatID As Long
    
    On Error Resume Next
    
    strSql = "SELECT strVoucherFormat FROM VoucherType WHERE lngVoucherTypeID=" & ltxtType.ID
    'Set recType = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recType.EOF Then
        Select Case recType!strVoucherFormat
        Case "1" ' 收款凭证 "
            lngFormatID = 54
        Case "2" ' 付款凭证
            lngFormatID = 55
        Case Else
            lngFormatID = 41
        End Select
    Else
        lngFormatID = 41
    End If
    recType.Close
    Set recType = Nothing
    mlngFormatID = lngFormatID
    
    'strCondVersion = " And (bytVersion Mod " & gVersionType * 2 & ">=" & gVersionType & ")"
    strCondVersion = " And ( MOD(bytVersion, " & gVersionType * 2 & ")>=" & gVersionType & ")"
    'strSql = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID=" & lngFormatID & " And (Not blnIsInActive) " & strCondVersion _
           & " ORDER BY lngTemplateID"
    strSql = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID=" & lngFormatID & " And (blnIsInActive=0) " & strCondVersion _
           & " ORDER BY lngTemplateID"
    ltxtTemplate.ClearRefer
    'Set ltxtTemplate.Recordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set ltxtTemplate.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtTemplate.Comparts = 2
    ltxtTemplate.AddRefer "<新增>"
    ltxtTemplate.AddRefer "<修改>"
    ltxtTemplate.AddRefer "<删除>"
    If lngID > 0 Then
        ltxtTemplate.SeekId lngID
        If ltxtTemplate.ID = 0 Then
            ltxtTemplate.ReferRow = 4
        End If
    Else
        If Not ltxtTemplate.Recordset Is Nothing Then
            ltxtTemplate.ReferRow = 4
        Else
            ltxtTemplate.Text = ""
        End If
    End If
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    On Error Resume Next
    If (TypeOf Screen.ActiveControl Is ListText) Then
        If Not Screen.ActiveControl.ReferVisible Then
            If KeyCode = vbKeyReturn Then
               KeyCode = 0
               SendKeys "{Tab}", True
            End If
        End If
    Else
        If KeyCode = vbKeyReturn Then
           KeyCode = 0
           SendKeys "{Tab}", True
        End If
    End If
End Sub


'生成费用分摊凭证
Private Function GenVoucher() As Boolean
    Dim dtmEnd As Date
    Dim intVoucher As Integer, lngCntDetail As Long
    Dim strRemark As String
    Dim strCode As String, strCode1 As String, strCode2 As String
    Dim strSql As String
    Dim recLoss As rdoResultset
    Dim lngCnt As Long
    Dim dblBalance As Double