frmfixedvoucher.frm

金算盘软件代码

        End If
    End If
    If Not blnOK Then
        ShowMsg Me.hwnd, "有固定资产凭证未存盘，不能生成凭证", vbExclamation, Me.Caption
        Exit Sub
    End If
    If gclsBase.PeriodClosed(gclsBase.BaseDate) = -1 Then
        ShowMsg Me.hwnd, "本会计期间已经结帐，不能生成凭证", vbExclamation, Me.Caption
        Exit Sub
    End If
    cmdVoucher(8).Enabled = False
    If Not mblnVoucherOK Then
        Call MakeVoucher
    End If
    If Not mblnVoucherOK Then
        cmdVoucher(8).Enabled = True
        Exit Sub
    End If
    '凭证类型校验科目必有、必无
    If Not CheckVoucherAccount() Then
        cmdVoucher(8).Enabled = True
        Exit Sub
    End If
    i = 0
    ReDim mVoucherID(0)
    On Error GoTo 0
    With msgVoucherGrid
        gclsBase.BaseWorkSpace.BeginTrans
        Do While i < .Rows
            If .TextMatrix(i, 4) <> "" Then
                If Not WriteVoucher(i) Then
                    GoTo Errors1
                End If
            End If
            i = i + 1
        Loop
        gclsBase.BaseWorkSpace.CommitTrans
    End With
    Unload Me
    For i = 0 To UBound(mVoucherID)
        If mVoucherID(i) > 0 Then
            Call BillPublic.ShowBill(50, mVoucherID(i))
            FrmVoucher.blnAutoVoucer False
        End If
'        Call BillPublic.VoucherMustSave
'        Do While True
'            If lngFormHwnd(25) = 0 Then
'                Exit Do
'            End If
'            DoEvents
'        Loop
'        '判断是否存盘
'        For Each vntMessage In mclsMainControl.Messages
'            If vntMessage = Message.msgReceipt41 Then
'                '删除凭证
'                gclsBase.BaseWorkSpace.BeginTrans
'                strSql = "DELETE FROM Voucher WHERE lngVoucherID=" & mVoucherID(i)
'                gclsBase.BaseDB.Execute strSql
'                strSql = "DELETE FROM VoucherDetail WHERE lngVoucherID=" & mVoucherID(i)
'                gclsBase.BaseDB.Execute strSql
'                gclsBase.BaseWorkSpace.CommitTrans
'                mclsMainControl.Messages.Remove CStr(vntMessage) '清除消息
'            End If
'        Next
    Next i
    Exit Sub
Errors1:
    gclsBase.BaseWorkSpace.RollBacktrans
    If Err.Description <> "" Then
        ShowMsg Me.hwnd, Err.Description, vbExclamation, Me.Caption
    End If
    cmdVoucher(8).Enabled = True
    Unload Me
    Exit Sub
End Sub

Private Sub mclsMainControl_ChildActive()
    frmMain.SetEditUnEnabled
End Sub

Private Sub msgVoucher_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgVoucher
        If x < .ColWidth(10) And y < .Rows * .RowHeight(0) And y > .RowHeight(0) Then
            .MousePointer = vbCustom
        Else
            .MousePointer = vbDefault
        End If
    End With
End Sub
Private Sub msgVoucher_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgVoucher
        mblnVoucherOK = False
        If x < .ColWidth(10) And y < .Rows * .RowHeight(0) And y > .RowHeight(0) Then
            If Trim(.TextMatrix(.Row, 10)) = "" Then
                If C2lng(.TextMatrix(.Row, 2)) > 0 And C2lng(.TextMatrix(.Row, 3)) > 0 And C2lng(.TextMatrix(.Row, 4)) > 0 Then
                    .TextMatrix(.Row, 10) = "√"
                Else
                    ShowMsg hwnd, "请指定变动方式的对应科目、凭证类型及模板", vbOKOnly + vbExclamation, Caption
                End If
            Else
                .TextMatrix(.Row, 10) = ""
            End If
        End If
    End With
End Sub
'Private Sub optVoucher_Click(Index As Integer)
'    mblnVoucherOK = False
'End Sub
Private Sub stbVoucher_Click(PreviousTab As Integer)
    If msgVoucher.Rows = 1 And stbVoucher.Tab > 0 Then
        stbVoucher.Tab = 0
        ShowMsg Me.hwnd, "无变动资料可以生成凭证", vbExclamation, Me.Caption
        Exit Sub
    End If
    If stbVoucher.Tab = 0 Then
        cmdVoucher(6).Enabled = False
        Call Form_Resize
    Else
        cmdVoucher(6).Enabled = True
    End If
    If stbVoucher.Tab = 1 Then
        cmdVoucher(7).Enabled = False
        If Not mblnVoucherOK Then
            Call MakeVoucher
        End If
    Else
        cmdVoucher(7).Enabled = True
    End If
End Sub
'生成凭证
Private Sub MakeVoucher()
    '校验录入
    Dim i As Integer
    Dim j As Integer
    Dim strFixedAccount As String
    Dim strSql As String
    Dim recs1 As rdoResultset
    Dim lngOldAccountID As Long
    Dim lngFixedMethodID As Long
    Dim strAccountCode As String
    Dim strAlterID As String
    On Error GoTo Err_Handle
    '锁定变动记录
    With msgVoucher
        strAlterID = ""
        For i = 1 To .Rows - 1
            If Trim(.TextMatrix(i, 10)) <> "" Then
                strAlterID = strAlterID & "," & .TextMatrix(i, 0)
            End If
        Next i
    End With
    On Error GoTo 0
    If Not ExclusiveIn(Caption, mclsMainControl.LogID) Then
        mblnVoucherOK = False
        Exit Sub
    End If
    strSql = "SELECT strSetting FROM Setting WHERE lngModuleID=10 AND RTrim(LTrim(strKey))='固定资产'"
    Set recs1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    lngOldAccountID = Val(recs1!strSetting)
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngOldAccountID
    Set recs1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recs1.EOF Then
        stbVoucher.Tab = 0
        ShowMsg Me.hwnd, "请选择固定资产科目", vbExclamation, Me.Caption
        mblnVoucherOK = False
        Exit Sub
    ElseIf recs1!blnIsDepartment Or recs1!blnIsCustomer Or recs1!blnIsEmployee Or recs1!blnIsClass1 Or recs1!blnIsClass2 Then
        stbVoucher.Tab = 0
        ShowMsg Me.hwnd, "固定资产科目不能有辅助核算属性", vbExclamation, Me.Caption
        mblnVoucherOK = False
        Exit Sub
    End If
    strAccountCode = recs1!strAccountCode
    strFixedAccount = Trim(recs1!strAccountCode & " " & recs1!strAccountName)
    i = 1
    With msgVoucher
        Do While i < .Rows
            If .TextMatrix(i, 10) = "√" Then
                mblnVoucherOK = True
                Exit Do
            End If
            i = i + 1
        Loop
    End With
    If Not mblnVoucherOK Then
        stbVoucher.Tab = 0
        ShowMsg Me.hwnd, "请选择生成凭证的变动资料", vbExclamation, Me.Caption
    End If
    msgVoucherGrid.Clear
    msgVoucherGrid.Rows = 1
    i = 1
'    If optVoucher(0).Value = True Then    '按卡片生成
        With msgVoucher
            Do While i < .Rows
                If .TextMatrix(i, 10) = "√" And .TextMatrix(i, 2) > 0 And .TextMatrix(i, 3) > 0 And .TextMatrix(i, 4) > 0 Then
                    If msgVoucherGrid.Rows > 1 Then
'                        msgVoucherGrid.AddItem ("")
'                        msgVoucherGrid.AddItem ("")
                    End If
                    Call Voucher(i, strFixedAccount, lngOldAccountID, strAccountCode)
                    
'                    Debug.Print msgVoucherGrid.TextMatrix(0, 14)
'                    Debug.Print msgVoucherGrid.TextMatrix(1, 14)
'                    Debug.Print msgVoucherGrid.TextMatrix(2, 14)
                    
                End If
                i = i + 1
            Loop
        End With
'    Else    '按变动方式生成
'        mclsGrid1.ColSort(7) = True
'        mclsGrid1.Sort 7, 1
'        With msgVoucher
'            i = 1
'            lngFixedMethodID = 0
'            Do While i < .Rows
'                If .TextMatrix(i, 10) = "√" And .TextMatrix(i, 7) <> lngFixedMethodID Then
'                    lngFixedMethodID = .TextMatrix(i, 7)
'                    If msgVoucherGrid.Rows > 1 Then
'                        msgVoucherGrid.AddItem ("")
'                        msgVoucherGrid.AddItem ("")
'                    End If
'                    j = i
'                    Do While j < .Rows
'                        If .TextMatrix(j, 10) = "√" And lngFixedMethodID = _
'                            .TextMatrix(j, 7) Then
'                            Call Voucher(j, strFixedAccount, lngOldAccountID, strAccountCode)
'                        End If
'                        j = j + 1
'                    Loop
'                End If
'                i = i + 1
'            Loop
'        End With
'    End If
Exit Sub
Err_Handle:
    mblnVoucherOK = False
End Sub
'生成凭证子程序
Private Sub Voucher(ByVal i As Integer, ByVal strFixedAccount As String, _
    ByVal lngOldAccountID As String, ByVal strAccountCode As String)
    Dim strAccount As String
    Dim strSql As String
    Dim recs1 As rdoResultset
    Dim lngRow As Long
    Dim lngAccountID As Long
    Dim dblValue As Double
    Dim dblCurrValue As Double
    Dim strRemark As String
    Dim strFixeddirection As String    '固定资产科目方向
    Dim lngVoucherTypeID As Long
    Dim lngTemplateID As Long
    Dim lngFixedAlterID As Long
    Dim lngLastFixedAlterID As Long
    Dim dblAlterDeprection As Double
    Dim dblAccountValue As Double     '固定资产科目金额
    Dim lngCurrencyID As Long
    '上次变动记录的原值组成
    Dim recLast As rdoResultset
    '本次变动记录的原值组成
    Dim recNow As rdoResultset

    '变动资料Grid
    With msgVoucher
        If .TextMatrix(i, 10) = "√" Then
            dblValue = C2Dbl(.TextMatrix(i, 6))
            strRemark = Trim(.TextMatrix(i, 5))
            lngAccountID = .TextMatrix(i, 2)
            lngVoucherTypeID = .TextMatrix(i, 3)
            lngTemplateID = .TextMatrix(i, 4)
            lngFixedAlterID = .TextMatrix(i, 0)
            '求累计折旧
            If GetDeprection(lngFixedAlterID) <> 0 Then
                dblAlterDeprection = GetDeprection(lngFixedAlterID)
            Else
                dblAlterDeprection = C2Dbl(.TextMatrix(i, 8))
            End If
            lngLastFixedAlterID = C2lng(.TextMatrix(i, 9))
            
            '本次变动记录的原值组成
'            strSql = "SELECT FixedCost.lngCurrencyID, FixedCost.dblCurrAmount, FixedCost.dblAmount " _
'                & "FROM FixedCost WHERE FixedCost.lngFixedAlterID=" & lngFixedAlterID
'            Set recNow = gclsBase.BaseDB.OpenResultset(strSql)
'            If Not recNow.EOF Then
'                recNow.MoveLast
'                recNow.MoveFirst
'            End If
'            strSql = "SELECT FixedCost.lngCurrencyID, FixedCost.dblCurrAmount, FixedCost.dblAmount " _
'                & "FROM FixedCost WHERE FixedCost.lngFixedAlterID=" & lngLastFixedAlterID
'            Set recLast = gclsBase.BaseDB.OpenResultset(strSql)
'            If Not recLast.EOF Then
'                recLast.MoveLast
'                recLast.MoveFirst
'            End If
'            '根据本次变动搜索上次变动
'            dblAccountValue = 0
'            Do While Not recNow.EOF
'                recLast.FindFirst "lngCurrencyID=" & recNow!lngCurrencyID
'                If recLast.NoMatch Then
'                    dblValue = recNow!dblAmount
'                    dblCurrValue = recNow!dblCurrAmount
'                Else
'                    dblValue = recNow!dblAmount - recLast!dblAmount
'                    dblCurrValue = recNow!dblCurrAmount - recLast!dblCurrAmount
'                End If
'                dblAccountValue = dblAccountValue + dblValue
                lngCurrencyID = gclsBase.NaturalCurId
                If dblValue <> 0 Then
                    Call FixedAccountVoucher(strRemark, strAccountCode, strFixedAccount, dblValue, _
                        dblValue, lngOldAccountID, lngVoucherTypeID, lngTemplateID, lngFixedAlterID _
                        , lngCurrencyID)