frmfixedoldwizard.frm

金算盘软件代码

End Sub

Private Sub FinishWizard()
    Dim strSql As String
    Dim intVoucherNO As Long
    Dim strVoucherNo As String
    Dim intYear As Integer
    Dim bytPeriod As Byte
    Dim strDate As String
    Dim i As Integer
    Dim recVoucher As rdoResultset
    Dim lngVoucherID As Long
    Dim lngVoucherDetailID As Long
    Dim strDebitAccountCode As String
    Dim lngOperatorID As Long
    Dim datStart As Date
    Dim datEnd As Date
    Dim lngNaturalCurID As Long
    Dim j As Integer
    Dim strRemark As String
    strRemark = Trim(IIf(ltxtResume.ID > 0, ltxtResume.TextMatrix(ltxtResume.ReferRow, 3), ltxtResume.Text))
    Do While StrLen(strRemark) > 40
        strRemark = Left$(strRemark, Len(strRemark) - 1)
    Loop
    If strRemark = "" Then
        strRemark = " "
    End If
    
    cmdArr(3).Enabled = False
    lngNaturalCurID = gclsBase.NaturalCurId
    '录入校验
    If Val(litAccount.TextMatrix(litAccount.ReferRow, 1)) = 0 Then
        stbOldWizard.Tab = 0
        ShowMsg Me.hwnd, "请选择折旧科目", vbInformation, Me.Caption
        litAccount.SetFocus
        Exit Sub
    End If
    If Val(ltxtTemplet.TextMatrix(ltxtTemplet.ReferRow, 1)) = 0 Then
        stbOldWizard.Tab = 1
        ltxtTemplet.SetFocus
        ShowMsg Me.hwnd, "请选择凭证模板", vbInformation, Me.Caption
        Exit Sub
    Else
        SaveSet 1, "计提折旧", "凭证模板", ltxtTemplet.ID, True, 0
    End If
    If Val(ltxtType.TextMatrix(ltxtType.ReferRow, 1)) = 0 Then
        stbOldWizard.Tab = 1
        ltxtType.SetFocus
        ShowMsg Me.hwnd, "请选择凭证类型", vbInformation, Me.Caption
        Exit Sub
    Else
        strSql = "SELECT * FROM VoucherType WHERE strVoucherFormat='0' AND lngVoucherTypeID=" & ltxtType.ID
        Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recVoucher.EOF Then
           recVoucher.Close
           Set recVoucher = Nothing
            stbOldWizard.Tab = 1
            ltxtType.SetFocus
           If Visible Then ShowMsg hwnd, "不能选择收付款凭证类型！", vbOKOnly + vbInformation, Caption
           Exit Sub
        Else
           recVoucher.Close
           Set recVoucher = Nothing
        End If
        SaveSet 1, "计提折旧", "凭证类型", ltxtType.ID, True, 0
    End If
'    If Len(Trim(ltxtResume.Text)) = 0 Then
'        stbOldWizard.Tab = 1
'        ltxtResume.SetFocus
'        ShowMsg Me.hwnd, "请选择凭证摘要", vbInformation, Me.Caption
'        Exit Sub
'    End If
    '调用计算
    If Not mblnVoucherFinish Then
        Call oldFixedVoucher
        If Len(mstrReport) > 3 Then
            Call ReportFixed
            If stbOldWizard.TabVisible(2) Then
                stbOldWizard.Tab = 2
            Else
                stbOldWizard.Tab = 3
            End If
            cmdArr(3).Enabled = True
            Exit Sub
        End If
    End If
    If Not mblnVoucherFinish Then
        cmdArr(3).Enabled = True
        Exit Sub
    End If
    '凭证类型有无科目校验
    If Not CheckVoucherAccount() Then
        cmdArr(3).Enabled = True
        Exit Sub
    End If
'    If msgOldWizard.Rows = 1 Then
'        ShowMsg Me.hWnd, "请先填写固定资产卡片再计算折旧", vbInformation, Me.Caption
'        Exit Sub
'    End If
    '写回凭证库
    '写凭证头
    Me.MousePointer = vbHourglass
    pgbWizard.Max = 100
    pgbWizard.Min = 0
    pgbWizard.Value = 0
    intYear = gclsBase.AccountYear
    bytPeriod = gclsBase.Period
    
    strVoucherNo = TransferPublic.GetMaxNO(intYear, bytPeriod, 41, ltxtType.ID, gclsBase.BaseDate)
    intVoucherNO = CInt(Right(strVoucherNo, 4))
    If intVoucherNO = 0 Then
        Me.MousePointer = vbDefault
        If gclsBase.NoOrder = True Then
            ShowMsg hwnd, "自动生成的凭证编号不满足序时控制", vbExclamation, Caption
        Else
            ShowMsg hwnd, "凭证编号生成失败！", vbExclamation, Caption
        End If
        cmdArr(3).Enabled = True
        Exit Sub
    End If
    strDate = Format(gclsBase.BaseDate, "yyyy-mm-dd")
    lngOperatorID = gclsBase.OperatorID
    i = 1
    strDebitAccountCode = ""
    With msgOldWizard
        Do While i < .Rows - 1
            strDebitAccountCode = strDebitAccountCode & " " & .TextMatrix(i, 1)
            i = i + 1
            pgbWizard.Value = i * 50 / .Rows
        Loop
    End With
    lngVoucherID = GetNewID("Voucher")
    strSql = "INSERT INTO Voucher (lngVoucherID , lngVoucherTypeID,intVoucherNO" _
        & ",intYear,bytPeriod,strDate,lngTemplateID,lngOperatorID," _
        & "strDebitAccountCode,strCreditAccountCode,lngVoucherSourceID" _
        & ") VALUES(" & lngVoucherID & " , " & ltxtType.TextMatrix(ltxtType.ReferRow, 1) & "," & intVoucherNO & "," _
        & intYear & "," & bytPeriod & ",'" & strDate & "'," & ltxtTemplet.ID _
        & "," & lngOperatorID & ",'" _
        & strDebitAccountCode & "'," & litAccount.TextMatrix(litAccount.ReferRow, 2) & ",15)"
    On Error GoTo Errors1
    gclsBase.BaseWorkSpace.BeginTrans
    If Not gclsBase.ExecSQL(strSql) Then GoTo Errors1
    '写明细凭证
    i = 1
    With msgOldWizard
        j = 0
        Do While i < .Rows
            strSql = "SELECT lngVoucherID FROM VoucherDetail WHERE lngVoucherID=" & lngVoucherID _
                & " AND lngAccountID=" & .TextMatrix(i, 0) & " AND intDirection=" & _
                IIf(.TextMatrix(i, 9) = "", -1, 1) & " AND lngDepartmentID=" & .TextMatrix(i, 6)
            Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recVoucher.EOF Then
                lngVoucherDetailID = GetNewID("VoucherDetail")
                strSql = "INSERT INTO VoucherDetail (lngVoucherID,lngVoucherDetailID,strRemark,lngAccountID," _
                    & "intDirection,dblAmount,lngClassID1,lngClassID2,lngCustomerID," _
                    & "lngDepartmentID,lngEmployeeID,lngCurrencyID,dblCurrencyAmount,dblRate,lngRowID) " _
                    & "VALUES(" & lngVoucherID & "," & lngVoucherDetailID & ",'" & strRemark & "'," & .TextMatrix(i, 0) & "," _
                    & IIf(.TextMatrix(i, 9) = "", -1, 1) & "," & Format(IIf(.TextMatrix(i, 9) = "", _
                    .TextMatrix(i, 10), .TextMatrix(i, 9)), "#.00") _
                    & "," & .TextMatrix(i, 3) & "," & .TextMatrix(i, 4) & "," _
                    & .TextMatrix(i, 5) & "," & .TextMatrix(i, 6) & "," & .TextMatrix(i, 7) & "," _
                    & lngNaturalCurID & "," & Format(IIf(.TextMatrix(i, 9) = "", _
                    .TextMatrix(i, 10), .TextMatrix(i, 9)), "#.00") & ",1," & j & ")"
                gclsBase.BaseDB.Execute strSql
            Else
                strSql = "UPDATE VoucherDetail SET dblAmount=dblAmount+" & Format(IIf(.TextMatrix(i, 9) = "", _
                    .TextMatrix(i, 10), .TextMatrix(i, 9)), "#.00") & ",dblCurrencyAmount=dblCurrencyAmount +" _
                    & Format(IIf(.TextMatrix(i, 9) = "", .TextMatrix(i, 10), .TextMatrix(i, 9)), "#.00") _
                    & " WHERE lngVoucherID=" & lngVoucherID & " AND lngAccountID=" & .TextMatrix(i, 0) _
                    & " AND intDirection=" & IIf(.TextMatrix(i, 9) = "", -1, 1)
                gclsBase.BaseDB.Execute strSql
            End If
            i = i + 1
            pgbWizard.Value = pgbWizard.Value + 50 / .Rows
            j = j + 1
        Loop
    End With
    '会计期间加1
'    strSql = "Update FixedCard SET FixedCard.intPeriod=FixedCard.intPeriod+1 WHERE " _
'        & "FixedCard.lngFixedCardID IN(SELECT lngFixedCardID FROM FixedArea)"
'    Set qrfQueryDef = gclsBase.BaseDB.CreateQueryDef("", strSql)
    Call gclsBase.DateOfPeriod(intYear, CInt(bytPeriod), datStart, datEnd)
'    qrfQueryDef("strNowDate") = Format(datstart, "yyyy-mm-dd")
'    qrfQueryDef("Used") = mblnUsed
'    qrfQueryDef.Execute
'    strSql = "INSERT INTO FixedAlter(strDate,dblDeprection,bytAlterType) Value(" _
'        & Format(datStart, "yyyy-mm-dd") & "," & mdblValue & ",4)"
'    gclsBase.ExecSQL strSql
    '写余额表
    If Not mdlAccount.ChangeAllAccount_from_Voucher("I", lngVoucherID) Then
        GoTo Errors1
    End If
    BillPublic.blnModifyMaxNO intYear, bytPeriod, 41, ltxtType.TextMatrix(ltxtType.ReferRow, 1), intVoucherNO
    gclsBase.BaseWorkSpace.CommitTrans
    mlngVoucherID = lngVoucherID
    pgbWizard.Value = 100
    mblnFinish = True
    Me.MousePointer = vbDefault
    gclsSys.SendMessage Me.hwnd, msgReceipt41
    Unload Me
    If mlngVoucherID > 0 Then
        BillPublic.ShowBill 50, mlngVoucherID
    End If
    Exit Sub
Errors1:
    ShowMsg Me.hwnd, "数据库正被其他用户使用，不能生成凭证", vbInformation, Me.Caption
'    Call BillPublic.blnMaxNODecrease(intYear, bytPeriod, 41, ltxtType.TextMatrix(ltxtType.ReferRow, 1), _
'        intVoucherNO)
    gclsBase.BaseWorkSpace.RollBacktrans
    pgbWizard.Value = 0
    cmdArr(3).Enabled = True
    Me.MousePointer = vbDefault
End Sub
'初始化凭证模板
Private Sub InitTemplet()
    Dim strSql As String
    Dim recResultset As rdoResultset
    ltxtTemplet.ClearRefer
    strSql = "SELECT lngtemplateID, strTemplateName FROM Template WHERE lngReceiptTypeID=41 " _
        & "AND (((MOD(bytVersion , " & (gVersionType * 2) & ")) > " & (gVersionType - 1) & ")) " _
        & " ORDER BY lngTemplateID"
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recResultset.EOF Then
        recResultset.MoveLast
        recResultset.MoveFirst
    End If
    ltxtTemplet.SeekCol = "1,2"
    Set ltxtTemplet.Recordset = recResultset
    ltxtTemplet.AddRefer "<新增>"
    ltxtTemplet.AddRefer "<修改>"
    ltxtTemplet.AddRefer "<删除>"
    ltxtTemplet.ReferRow = 4 + IIf(ltxtTemplet.Recordset.RowCount > 0, ltxtTemplet.Recordset.RowCount - 1, 0)
    recResultset.Close
    Set recResultset = Nothing
End Sub
'初始化凭证类型
Private Sub InitType()
    Dim strSql As String
    Dim recResultset As rdoResultset
    On Error Resume Next
    ltxtType.ClearRefer
    strSql = "SELECT VoucherType.lngVoucherTypeID, VoucherType.strVoucherTypeName " _
        & "FROM VoucherType WHERE blnIsInActive = 0 "
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtType.SeekCol = "1,2"
    Set ltxtType.Recordset = recResultset
    If Not recResultset.EOF Then
        recResultset.MoveLast
        recResultset.MoveFirst
    End If
    ltxtType.AddRefer "<新增>"
    ltxtType.AddRefer "<修改>"
    ltxtType.AddRefer "<删除>"
    ltxtType.ReferRow = 4 + IIf(ltxtType.Recordset.RowCount > 0, ltxtType.Recordset.RowCount - 1, 0)
    recResultset.Close
    Set recResultset = Nothing
End Sub
'初始化摘要
Private Sub InitResume()
    Dim strSql As String
    Dim recResultset As rdoResultset
    ltxtResume.ClearRefer
    strSql = "SELECT lngRemarkID,strRemarkCode,strRemarkName FROM Remark ORDER BY strRemarkCode"
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    ltxtResume.SeekCol = "1,2,3"
    ltxtResume.CodeSort = True
    If Not recResultset.EOF Then
        recResultset.MoveLast
        recResultset.MoveFirst
    End If
    Set ltxtResume.Recordset = recResultset
    ltxtResume.AddRefer "<新增>"
    ltxtResume.AddRefer "<修改>"
    If recResultset.EOF And ltxtResume.Referrows > 2 Then
        ltxtResume.Referrows = 2
    End If
    ltxtResume.AddRefer "<删除>"
    ltxtResume.Text = "计提折旧"
    recResultset.Close
    Set recResultset = Nothing
End Sub
'初始化科目
Private Sub InitAccountID()
    Dim strSql As String
    Dim recResultset As rdoResultset
    Dim lngAccountID As Long
    strSql = "SELECT strSetting FROM Setting WHERE lngModuleID=10 AND " _
        & "Rtrim(LTrim(strKey))='累计折旧'"
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    lngAccountID = IIf(IsNull(recResultset!strSetting), 0, recResultset!strSetting)
'    strSql = "SELECT lngAccountID,strAccountCode,strAccountName FROM Account WHERE blnIsDetail=True AND blnIsCustomer=False " _
'        & "AND blnIsDepartment=False AND blnIsEmployee=False AND blnIsClass1=False AND " _
'        & " blnIsClass2=False AND blnIsQuantity=False AND blnIsInActive=0"
    strSql = "SELECT lngAccountID,strAccountCode,strAccountName FROM Account WHERE blnIsInActive = 0 ORDER BY strAccountCode "
    Set recResultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recResultset.EOF Then
        recResultset.MoveLast
        recResultset.MoveFirst
    End If
    litAccount.ClearRefer
    litAccount.SeekCol = "1,2,3"
    Set litAccount.Recordset = recResultset
    litAccount.AddRefer "<新增>"
    litAccount.AddRefer "<修改>"
    litAccount.AddRefer "<删除>"
    litAccount.SeekId lngAccountID
    recResultset.Close
    Set recResultset = Nothing
End Sub
'检查凭证类型的科目
Private Function CheckVoucherAccount() As Boolean
    Dim lngDebitAccountID() As Long               '借方科目
    Dim lngCreditAccountID(1) As Long             '贷方科目
    Dim lngVoucherTypeID As Long                  '凭证类型ID
    Dim recAccount As rdoResultset
    Dim strErr As String
    Dim strSql As String
    Dim i As Integer
    CheckVoucherAccount = False
    With msgOldWizard
        i = 0
        Do While i < .Rows - 1
            i = i + 1
            ReDim lngDebitAccountID(i)
            lngDebitAccountID(i - 1) = CLng(.TextMatrix(i, 0))
            strSql = "SELECT * FROM Account WHERE lngAccountID=" & CLng(.TextMatrix(i, 0))
            Set recAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            With recAccount
                If Not .EOF Then
                    If !blnIsCustomer Or !blnIsEmployee Or !blnIsClass1 Or !blnIsClass2 Or !blnIsQuantity Then
                        If CLng(msgOldWizard.Te