frmcalccost.frm

金算盘软件代码

                .mnuListEditMenu(intCnt).Enabled = True
            Else
                .mnuListEditMenu(intCnt).Enabled = False
            End If
        Else
            .mnuListEditMenu(intCnt).Enabled = False
        End If
        .mnuListEditMenu(intCnt).Visible = True
        .mnuListEditMenu(intCnt).Caption = "成本批次(&B)"
        
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        .mnuListEditMenu(intCnt).Enabled = (Not mclsGrid.IsEmpty)
        .mnuListEditMenu(intCnt).Visible = True
        .mnuListEditMenu(intCnt).Caption = "成本结转(&C)"
        
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        .mnuListEditMenu(intCnt).Enabled = ExistPlanOrSale()
        .mnuListEditMenu(intCnt).Visible = True
        .mnuListEditMenu(intCnt).Caption = "差异差价结转(&D)"
        
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(intCnt)      '----
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuEditFilter, .mnuListEditMenu(intCnt)    '筛选
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(intCnt)    '栏目设置
        .mnuListEditMenu(intCnt).Enabled = False
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(intCnt)      '----
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuToolRefresh, .mnuListEditMenu(intCnt)   '刷新
        intCnt = intCnt + 1
        Load .mnuListEditMenu(intCnt)
        Utility.CloneMenu .mnuFilePrint, .mnuListEditMenu(intCnt)     '打印
    End With
End Sub

'编辑菜单
Private Sub cmdEdit_Click()
    MakeListEditMenu
    PopupMenu frmMain.mnuListEdit, , cmdEdit.Left, cmdEdit.top + cmdEdit.Height
End Sub

'生成报表菜单
Private Sub MakeListReportMenu()
    Dim intCnt As Integer
    
    With frmMain
        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCnt)
        Next
        
        intCnt = 0
        .mnuListReportMenu(intCnt).Enabled = True
        .mnuListReportMenu(intCnt).Visible = True
        .mnuListReportMenu(intCnt).Caption = "存货明细帐(&M)"
        
        intCnt = intCnt + 1
        Load .mnuListReportMenu(intCnt)
        .mnuListReportMenu(intCnt).Enabled = True
        .mnuListReportMenu(intCnt).Visible = True
        .mnuListReportMenu(intCnt).Caption = "存货进销存汇总表(&H)"
    
    End With
End Sub

'报表菜单
Private Sub cmdReport_Click()
    MakeListReportMenu
    PopupMenu frmMain.mnuListReport, , cmdReport.Left, cmdReport.top + cmdReport.Height
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Select Case intIndex
    Case 0
        Report.ShowAcntBook 127, 100
    Case 1
        Report.ShowSumReport 592, 541
    End Select
End Sub

'处理编辑菜单
Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
    Dim dtmStart As Date, dtmEnd As Date
    Dim lngItemID As Long
    Dim strItemName As String
    Dim strSql As String
    Dim lngViewId As Long
    Dim recItem As rdoResultset
    Dim dblQuantity As Double
    Dim dblAmount As Double
    
    Select Case intIndex
    Case 0    '"全部商品"
        '计算成本
        If CalcAllCost() Then
            SaveSet 1, "成本计算", "计算方式", "全部商品", True, "String"
            '更新商品列表
            RefreshGrid
        End If
    Case 1  '"快速计算"
        '计算成本
        If CalcAllCost(mstrMethodCode, True) Then
            SaveSet 1, "成本计算", "计算方式", "快速计算", True, "String"
            '更新商品列表
            RefreshGrid
        End If
    Case 2  '调整成本
        frmMain.mnuListEditMenu(intIndex).Checked = (Not frmMain.mnuListEditMenu(intIndex).Checked)
        If frmMain.mnuListEditMenu(intIndex).Checked Then
            SaveSet 1, "成本计算", "调整成本", "1", True, "Long"
        Else
            SaveSet 1, "成本计算", "调整成本", "0", True, "Long"
        End If
    Case 4  '"计算底稿(&S)"
        If IsNumeric(mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColID)) Then
            '取本期起止日期、商品ID、商品名称
            lngItemID = mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColID)
            strItemName = mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColItemCode)
            '设置计算底稿的方法、商品、起止日期
            If lngItemID > 0 Then
                '显示成本底稿
                Load frmCalcScript
                frmCalcScript.SetParameters lngItemID, strItemName, GetintYear(cboCost(0).Text), GetbytPeriod(cboCost(0).Text), mstrMethodCode, CalDate.Text
                frmCalcScript.ZOrder 0
            End If
        End If
    Case 5  '"成本批次"
        If IsNumeric(mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColID)) Then
            If Not CloseCost(cboCost(0).Text) Then
                '取本期起止日期、商品ID、商品名称
                dtmEnd = CDate(CalDate.Text)
                gclsBase.PeriodOfDate dtmEnd, dtmStart
                lngItemID = mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColID)
                strItemName = mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColItemCode)
                If Format(dtmStart - 1, "yyyy-mm-dd") > mclsGrid.Grid.CellValue(mclsGrid.Grid.Row, mlngColCalcDate) And Format(dtmStart - 1, "yyyy-mm-dd") > Format(gclsBase.BeginDate, "yyyy-mm-dd") Then
                    If ShowMsg(hwnd, "由于上期未计算成本，可能会造成某些入库单据不能选择！是否继续?", vbQuestion + vbYesNo, Caption) = vbNo Then
                        lngItemID = 0
                    End If
                End If
                If lngItemID > 0 Then
                    '设置成本批次商品、起止日期
                    frmCalcSingle.SetPararmeters lngItemID, strItemName, dtmStart, dtmEnd
'                    显示成本批次
                    frmCalcSingle.Show
                    frmCalcSingle.ZOrder 0
                End If
            Else
                ShowMsg hwnd, "本期已结转成本，不能修改商品成本计算批次！", vbOKOnly + vbExclamation, Caption
            End If
        End If
    Case 6  '"成本结转(&C)"
        If Not gclsBase.PeriodClosed(gclsBase.BaseDate) Then
            If GetSet(1, "成本计算", "计算方式", "全部商品") = "全部商品" Then
                If ExclusiveIn("成本结转", -1, "用其他用户在使用该帐套，不能结转成本") Then
                    If lngItemID = 0 Then
                        With frmPurchaseSaleVoucher
                            .SetManner "结转成本", CalDate.Text
                            .Show vbModal
                        End With
                        Set frmPurchaseSaleVoucher = Nothing
                    Else
                        ShowMsg hwnd, "先计算本期商品成本", vbOKOnly + vbExclamation, Caption
                    End If
                End If
            Else
                ShowMsg hwnd, "每期期末最后一次成本计算方式必须选择“全部计算”", vbOKOnly + vbExclamation, Caption
            End If
        Else
            ShowMsg hwnd, "本期已结帐，不能再结转成本！", vbOKOnly + vbExclamation, Caption
        End If
    Case 7  '"差异(差价)结转(&C)"
        If GetSet(1, "成本计算", "计算方式", "全部商品") = "全部商品" Then
            If ExclusiveIn("成本结转", -1, "用其他用户在使用该帐套，不能结转差异(差价)") Then
                If lngItemID = 0 Then
                    frmCloseCost.Show vbModal
                Else
                    ShowMsg hwnd, "先计算本期商品成本", vbOKOnly + vbExclamation, Caption
                End If
            End If
        Else
            ShowMsg hwnd, "每期期末最后一次成本计算方式必须选择“全部计算”", vbOKOnly + vbExclamation, Caption
        End If
    Case 9  '"筛选(&F)"
        FilterItem
    Case 10  '"栏目设置(&)"
        Select Case MethodCode(cboCost(1).Text)
        Case cmPlan
            lngViewId = PlanViewID
        Case cmRealDiff
            lngViewId = SaleViewID
        Case Else
            lngViewId = RealViewID
        End Select
        If mclsGrid.ListSet.ShowListSet(lngViewId, False) Then
            RefreshGrid
        End If
    Case 12  '"刷新"
        mclsMainControl_ToolRefresh
    Case 13  '"打印"
        mclsMainControl_FilePrint
    End Select
End Sub

Private Sub UpdateMenuStatu()
    With frmMain
        .mnuEditCopy.Enabled = False
        .mnuEditEdit.Enabled = False
        .mnuEditNew.Enabled = False
        .mnuEditDel.Enabled = False
        .mnuEditInActive.Enabled = False
        .mnuEditShowAll.Checked = False
        .mnuEditShowAll.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuEditColumn.Enabled = False
        .mnuEditFilter.Enabled = True
        .mnuEditSearch.Enabled = False
        .mnuEditNotepad.Enabled = False
        .mnuEditShowList.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuFilePrintSetup.Enabled = (Not mclsGrid.IsEmpty)
        .mnuFilePrint.Enabled = (Not mclsGrid.IsEmpty)
        .mnuToolRefresh.Enabled = True
        .SetToolBar
    End With
End Sub

Private Sub mclsMainControl_EditFilter()
    FilterItem
End Sub

Private Sub mclsMainControl_EditColumn()
    Dim lngViewId As Long
    
    Select Case MethodCode(cboCost(1).Text)
    Case cmPlan
        lngViewId = PlanViewID
    Case cmRealDiff
        lngViewId = SaleViewID
    Case Else
        lngViewId = RealViewID
    End Select
    If mclsGrid.ListSet.ShowListSet(lngViewId, False) Then
        RefreshGrid
    End If
End Sub

Private Sub mclsMainControl_ChildActive()
    UpdateMenuStatu
    Me.Refresh
End Sub


Private Sub FilterItem()
    Dim lngViewId As Long
    Dim strSql As String
    Dim blnFilterOk As Boolean
    
    mclsGrid.ListSet.SaveList
    Select Case MethodCode(cboCost(1).Text)
    Case cmPlan
        lngViewId = PlanViewID
    Case cmRealDiff
        lngViewId = SaleViewID
    Case Else
        lngViewId = RealViewID
    End Select
    If mclsGrid.ListSet.ListID = 0 Then
        mclsGrid.ListSet.SaveList
    End If
    strSql = Filter.ShowFilter(mclsGrid.ListSet.ListID, 1, , 1, , , blnFilterOk)
    If blnFilterOk Then
        mclsGrid.ListSet.ViewId = lngViewId
        RefreshGrid
    End If
End Sub

'检查某期间是否存在结转成本的凭证
Private Function CheckCostVoucher(strStartPeriod As String, strEndPeriod As String) As Boolean
    Dim strSql As String
    Dim recVoucher As rdoResultset
    Dim errNo As Long
    Dim strNote As String
    Dim clsVoucher As New clsVoucherMethod
    CheckCostVoucher = True
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT * FROM Voucher WHERE lngVoucherSourceID=" & vsCost _
        & " AND intYear || '年' || bytPeriod || '期末'>='" & strStartPeriod _
        & "' AND intYear || '年' || bytPeriod || '期末'<='" & strEndPeriod & "'"
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucher.EOF Then
        strNote = ""
        Do While Not recVoucher.EOF
            If strNote <> "" Then
                strNote = strNote & Chr(13) & Chr(10)
            End If
            If recVoucher!lngPostID > 0 Then
                strNote = strNote & recVoucher!intYear & "年" & recVoucher!bytPeriod & "期间的成本结转凭证已记帐，请先删除该凭证再计算成本！"
                CheckCostVoucher = False
                Exit Do
            ElseIf recVoucher!lngCheckerID > 0 Then
                strNote = strNote & recVoucher!intYear & "年" & recVoucher!bytPeriod & "期间的成本结转凭证已复核，请先删除该凭证再计算成本！"
                CheckCostVoucher = False
                Exit Do
            Else
                strNote = strNote & recVoucher!intYear & "年" & recVoucher!bytPeriod & "期间的成本已结转，是否删除该凭证?"
            End If
            recVoucher.MoveNext
        Loop
        If CheckCostVoucher Then
            If ShowMsg(hwnd, strNote, vbYesNo + vbQuestion, Caption) = vbYes Then
                recVoucher.MoveFirst
                Do While Not recVoucher.EOF
                    If recVoucher!lngPostID > 0 Or recVoucher!lngCheckerID > 0 Then
                        '生成冲销凭证
'                        CheckCostVoucher = clsVoucher.GenCancelVoucher(recVoucher!lngVoucherID)
                        CheckCostVoucher = False
                        Exit Do
                    Else
                        '删除过时凭证
                        clsVoucher.DeleteVoucher recVoucher!lngVoucherID, True
                    End If
                    recVoucher.MoveNext
                Loop
            Else
                CheckCostVoucher = False
            End If
        Else
            ShowMsg hwnd, strNote, vbExclamation, Caption
        End If
    End If
    recVoucher.Close
    Set clsVoucher = Nothing
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown