frmexpense.frm

金算盘软件代码

    End If
    
End Function

' 向导每步初始设置
Private Sub InitStep(TabIndex As Integer)
    Dim lngCnt As Long
    Me.MousePointer = vbHourglass
    
    Select Case TabIndex
    Case 0: InitAccount1       '管理费用
    Case 1: InitAccount2       '费用分配
    Case 2
        For lngCnt = 0 To TabIndex - 1
            If Not mblnValid(lngCnt) Then
                stabWizard.Tab = lngCnt
            End If
        Next lngCnt
        InitResult        '凭证预演
    End Select
    RefreshCmd
    Me.MousePointer = vbDefault
End Sub

' 向导完成后需执行的操作
Private Sub Execute()
    Dim lngCnt As Long, lngCntDetail As Long
    Dim errNo As Long
    Dim strMsg As String
    
    On Error GoTo ErrHandle
    
    If Not SaveVoucher(VoucherData) Then
        If VoucherData(0).ErrorString <> "" Then
            ShowMsg hwnd, "凭证生成失败：" & VoucherData(0).ErrorString, vbOKOnly + vbCritical, Caption
        Else
            ShowMsg hwnd, "没有凭证生成！", vbOKOnly + vbCritical, Caption
        End If
    Else
        lngCntDetail = 0
        For lngCnt = 0 To UBound(VoucherData)
            If VoucherData(lngCnt).Used Then
                If Not VoucherData(lngCnt).IsError Then
                    lngCntDetail = lngCntDetail + 1
                Else
                    strMsg = strMsg & Chr(13) & "第" & lngCnt & "张凭证" & VoucherData(lngCnt).ErrorString
                End If
            End If
        Next lngCnt
        If strMsg <> "" Then
            ShowMsg hwnd, "生成了" & lngCntDetail & "张凭证，其中：" & strMsg, vbOKOnly + vbExclamation, Caption
        End If
        gclsSys.SendMessage Me.hwnd, msgReceipt41
        For lngCnt = 0 To UBound(VoucherData)
            If VoucherData(lngCnt).Saved Then
                Me.Hide
                BillPublic.ShowBill 50, VoucherData(lngCnt).VoucherID
                Exit For
            End If
        Next lngCnt
    End If
    Exit Sub
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Sub

Private Sub cmdStep_Click(Index As Integer)
    Dim blnUnload As Boolean
    Dim strMsg As String
    
    blnUnload = False
    
    Select Case Index
    Case 0  '取消
        blnUnload = True
    Case 1  '上一步
        If stabWizard.Tab > 0 Then
            stabWizard.Tab = stabWizard.Tab - 1
        End If
    Case 2  '下一步
        If stabWizard.Tab < mintStepNum Then
            stabWizard.Tab = stabWizard.Tab + 1
        End If
    Case 3: '完成
        If ValidStep(mintStepNum) Then
            cmdStep(3).Enabled = False
            Execute
            blnUnload = True
        End If
    End Select
    
    If blnUnload Then
       Unload Me
    End If
End Sub

'重设按扭显示属性
Private Sub RefreshCmd()
    Dim lngCnt As Long
    
    Select Case stabWizard.Tab
    Case 0
        cmdStep(1).Enabled = False
        cmdStep(2).Enabled = True
    Case mintStepNum
        cmdStep(1).Enabled = True
        cmdStep(2).Enabled = False
    Case Else
        cmdStep(1).Enabled = True
        cmdStep(2).Enabled = True
    End Select
    
    '是否每步都合法
    For lngCnt = 0 To mintStepNum
        If Not mblnValid(lngCnt) Then
            Exit For
        End If
    Next lngCnt
    cmdStep(3).Enabled = (lngCnt > mintStepNum)
    
    '若是最后一步，把完成按扭变为有效
    If Not cmdStep(3).Enabled Then
        If stabWizard.Tab = mintStepNum Then
            cmdStep(3).Enabled = True
        End If
    End If

    If stabWizard.Tab = stabWizard.Tabs - 1 Then
        On Error Resume Next
        cmdStep(3).SetFocus
    Else
        On Error Resume Next
        cmdStep(2).SetFocus
    End If
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤初始化
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步：结余转入
Private Function InitAccount1()
    If fraWizard(0).Tag <> "已设置" Then
        fraWizard(0).Tag = "已设置"
        '结余转入
        RefreshAccount 1
        ltxtAcc1.SeekId GetSet(1, "管理费用分摊", "管理费用科目", 0)
    End If
End Function

'第二步：凭证选项初始
Private Function InitAccount2()
    RefreshAccount 21
    ltxtAcc20.SeekId GetSet(1, "管理费用分摊", "医疗支出科目", 0)
    spinRate0.Text = Format(GetSet(1, "管理费用分摊", "医疗支出比例", 0#), "0.00")
    RefreshAccount 22
    ltxtAcc21.SeekId GetSet(1, "管理费用分摊", "药品支出科目", 0)
    spinRate1.Text = Format(GetSet(1, "管理费用分摊", "药品支出比例", 0#), "0.00")
    RefreshAccount 23
    ltxtAcc22.SeekId GetSet(1, "管理费用分摊", "制剂生产科目", 0)
    spinRate2.Text = Format(GetSet(1, "管理费用分摊", "制剂生产比例", 0#), "0.00")
End Function

'第三步：凭证预缆初始
Private Function InitResult()
    Dim lngCnt As Long, lngCntDetail As Long, lngCntOrder As Long
    Dim strResult As String, strDetail As String, strAmount As String
    Dim strSql As String
    Dim recAccount As rdoResultset
    Dim lngLen As Long, lngSpace As Long
    
    If fraWizard(2).Tag <> "已设置" Then
        
        fraWizard(2).Tag = "已设置"
        
        '凭证模板参照
        RefreshTemplate
        lngCnt = CLng(GetSet(1, "管理费用分摊", "凭证摸板", 0))
        If lngCnt > 0 Then
            ltxtTemplate.SeekId lngCnt
        End If
        
        '凭证类型参照
        RefreshVoucherType
        lngCnt = CLng(GetSet(1, "管理费用分摊", "凭证类型", 0))
        If lngCnt > 0 Then
            ltxtType.SeekId lngCnt
        End If
        
        If Not GenVoucher Then
            txtResult.Text = ""
            Exit Function
        End If
        
        If UBound(VoucherData) < 100 And UBound(VoucherData(0).Detail) < 100 Then
            strResult = ""
            lngLen = 58
            For lngCnt = 0 To UBound(VoucherData)
                With VoucherData(lngCnt)
                    If .Used Then
                        For lngCntOrder = 0 To UBound(.Detail)
                            lngCntDetail = lngCntOrder
                            If .Detail(lngCntDetail).Amount <> 0 Then
                                If .Detail(lngCntDetail).Direction = adDebit Then
                                    strDetail = "借："
                                Else
                                    strDetail = "贷："
                                End If
                                strSql = "SELECT strAccountCode,strAccountName FROM Account " _
                                    & "WHERE lngAccountID=" & .Detail(lngCntDetail).AccountID
                                'Set recAccount = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
                                Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                                If Not recAccount.EOF Then
                                    strDetail = strDetail & recAccount!strAccountCode & " " _
                                        & Trim(recAccount!strAccountName)
                                    If .Detail(lngCntDetail).CustomerID > 0 Then
                                        strResult = strResult & strDetail & Chr(13) & Chr(10)
                                        strDetail = Space(4) & "— " & CustomerName(.Detail(lngCntDetail).CustomerID)
                                    End If
                                    If .Detail(lngCntDetail).DepartmentID > 0 Then
                                        strResult = strResult & strDetail & Chr(13) & Chr(10)
                                        strDetail = Space(4) & "— " & DepartmentName(.Detail(lngCntDetail).DepartmentID)
                                    End If
                                    If .Detail(lngCntDetail).EmployeeID > 0 Then
                                        strResult = strResult & strDetail & Chr(13) & Chr(10)
                                        strDetail = Space(4) & "— " & EmployeeName(.Detail(lngCntDetail).EmployeeID)
                                    End If
        '                            If .Detail(lngCntDetail).JobID > 0 Then
        '                                strDetail = strDetail & "/" & JobName(.Detail(lngCntDetail).JobID)
        '                            End If
                                    If .Detail(lngCntDetail).ClassID1 > 0 Then
                                        strResult = strResult & strDetail & Chr(13) & Chr(10)
                                        strDetail = Space(4) & "— " & Class1Name(.Detail(lngCntDetail).ClassID1)
                                    End If
                                    If .Detail(lngCntDetail).ClassID2 > 0 Then
                                        strResult = strResult & strDetail & Chr(13) & Chr(10)
                                        strDetail = Space(4) & "— " & Class2Name(.Detail(lngCntDetail).ClassID2)
                                    End If
                                End If
                                lngSpace = lngLen - StrLen(strDetail) - 14
                                If lngSpace < 0 Then lngSpace = 0
                                strDetail = strDetail & Space(lngSpace)
                                strAmount = Format(.Detail(lngCntDetail).Amount, "#0.00")
                                lngSpace = 14 - StrLen(strAmount)
                                If lngSpace < 0 Then lngSpace = 0
                                strDetail = strDetail & Space(lngSpace) & strAmount
                                strResult = strResult & strDetail & Chr(13) & Chr(10)
                            End If
                        Next lngCntOrder
                        strResult = strResult & String(lngLen / 2, "─") & Chr(13) & Chr(10)
                    End If
                End With
            Next lngCnt
        Else
            If UBound(VoucherData) > 0 Then
                strResult = "共有" & UBound(VoucherData) + 1 & "张凭证"
            Else
                strResult = "凭证共有" & UBound(VoucherData(0).Detail) + 1 & "笔分录"
            End If
        End If
        txtResult.Text = strResult
    End If
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  向导步骤合法检查
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'第一步，损益科目
Private Function ValidAccount1(Msg As String) As Boolean
    ValidAccount1 = True
    If ltxtAcc1.ID = 0 Then
        ValidAccount1 = False
        Msg = "请指定管理费用科目！"
    Else
        SaveSet 1, "管理费用分摊", "管理费用科目", ltxtAcc1.ID, True, "Long"
    End If
    fraWizard(2).Tag = ""
End Function

'第二步，结余分配
Private Function ValidAccount2(Msg As String) As Boolean
    Dim strSql As String
    Dim recAccount As rdoResultset
    
    mblnAcc22IsDetail = False
    
    ValidAccount2 = True
    If ValidAccount2 Then
        If ltxtAcc20.ID = 0 Then
            ValidAccount2 = False
            Msg = "输入医疗支出科目！"
        End If
    End If
    If ValidAccount2 Then
        If C2Dbl(spinRate0.Text) < 0 Then
            ValidAccount2 = False
            Msg = "医疗支出科目分摊比例不能小于0！"
        End If
        If C2Dbl(spinRate0.Text) > 100 Then
            ValidAccount2 = False
            Msg = "医疗支出科目分摊比例不能大于100！"
        End If
    End If
    If ValidAccount2 Then
        If ltxtAcc21.ID = 0 Then
            ValidAccount2 = False
            Msg = "输入药品支出科目！"
        End If
    End If
    If ValidAccount2 Then