frmcalccost.frm

金算盘软件代码

    strSql = strSelect & strFrom & strWhere
    If strCond <> "" Then
        strSql = strSql & " AND (" & strCond & ")"
    End If
    If mclsGrid.SortType = 1 Then
        strSql = strSql & " ORDER BY strItemCode"
    Else
        strSql = strSql & " ORDER BY strItemCode DESC"
    End If
    
    Set GetList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Exit Function
    
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
    Set GetList = Nothing
End Function

Private Sub InitGrid()
    Me.MousePointer = vbHourglass
    
    '设置日期
    chkTax.Value = Abs(CLng(GetSet(1, "成本计算", "是否含税", 1)))
    InitDate
    
    If cboCost(0).ListCount > 0 And cboCost(0).ListIndex = -1 Then
        cboCost(0).ListIndex = 0
'            DateClick
    End If
    
    '设置成本方法
    InitMethod
    
    picGrid.Visible = True
    
    If cboCost(1).ListCount = 0 Then
        cboCost(1).AddItem "移动平均"
    End If
    cboCost(1).ListIndex = 0
    '初始排序列
    InitSort
    If cboCost(3).ListCount > 0 Then
        cboCost(3).ListIndex = 0
    End If
    Me.MousePointer = vbDefault
End Sub

'计算期末日期
Private Sub DateClick()
    Dim dtmEndDate As Date
    Dim blnDateChange As Boolean
    
    Select Case cboCost(0).Text
    Case "本期末"
        gclsBase.GetBeginAndEndDate "本期", gclsBase.BaseDate, , dtmEndDate
   Case "上期末"
        gclsBase.GetBeginAndEndDate "上期", gclsBase.BaseDate, , dtmEndDate
    Case "本季末"
        gclsBase.GetBeginAndEndDate "本季度", gclsBase.BaseDate, , dtmEndDate
    Case "上季末"
        gclsBase.GetBeginAndEndDate "上季度", gclsBase.BaseDate, , dtmEndDate
    Case Else
        gclsBase.DateOfPeriod GetintYear(cboCost(0).Text), GetbytPeriod(cboCost(0).Text), , dtmEndDate
    End Select
    If IsDate(CalDate.Text) Then
        If CDate(CalDate.Text) <> dtmEndDate Then
            CalDate.Text = Format(dtmEndDate, "YYYY-MM-DD")
            blnDateChange = True
        End If
    Else
        CalDate.Text = Format(dtmEndDate, "YYYY-MM-DD")
        blnDateChange = True
    End If
    
    If blnDateChange Then
        '重新计算列表
        mstrMethodCode = ""
        MethodClick
    End If
End Sub

'初始日期选择框：所有未结帐、未结转成本的期间
Private Sub InitDate(Optional ByVal strDefaultPeriod As String)
    Dim strSql As String
    Dim recPeriod As rdoResultset
    Dim recItem As rdoResultset
    Dim intPeriod As Integer, dtmEnd As Date
    Dim intStartYear As Integer
    Dim strMinPeriod  As String
    Dim strMinCalcPeriod  As String
    Dim intYear As Integer
    Dim intCnt As Integer
    
    '启用日期
    
    GetStartPeriod intStartYear, intPeriod
    If mintYear <> intStartYear Then
        strMinPeriod = mintYear & "年01期末"
    Else
        strMinPeriod = intStartYear & "年" & Format(intPeriod, "00") & "期末"
    End If
    strMinCalcPeriod = strMinPeriod
'    intPeriod = gclsBase.Period
    strSql = "SELECT AccountPeriod.intYear || '年' || LTRIM(TO_CHAR(AccountPeriod.bytPeriod,'00')) || '期末' As strPeriod " _
        & "FROM AccountPeriod " _
        & "WHERE intYear*100+bytPeriod>=" & CLng(intStartYear) * 100 + intPeriod & " AND lngCloseID=0 " _
        & "ORDER BY intYear,bytPeriod"
    Set recPeriod = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recPeriod.EOF Then
        strMinCalcPeriod = recPeriod!strPeriod
        strSql = "SELECT strReCalcCost,blnIsCalcCost " _
            & "FROM Item,ItemNature WHERE Item.lngItemNatureID=ItemNature.lngItemNatureID " _
            & "AND strItemCategory='1' ORDER BY blnIsCalcCost DESC,strReCalcCost"
        Set recItem = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recItem.EOF Then
            If IsDate(recItem!strReCalcCost) And recItem!blnIsCalcCost = 1 Then
                intYear = gclsBase.FYearOfDate(CDate(recItem!strReCalcCost) + 1)
                If intYear < gclsBase.BeginYear Then
                    intYear = gclsBase.BeginYear
                End If
                If intYear = 0 Then
                    intYear = gclsBase.AccountYear
                    strMinCalcPeriod = Format(intYear, "0000") & "年" _
                    & Format(gclsBase.Period, "00") & "期末"
                Else
                    strMinCalcPeriod = Format(intYear, "0000") & "年" _
                    & Format(gclsBase.PeriodOfDate(CDate(recItem!strReCalcCost) + 1), "00") & "期末"
                End If
            End If
        End If
        If strMinCalcPeriod < recPeriod!strPeriod Then
            strMinCalcPeriod = recPeriod!strPeriod
        End If
        Do While Not recPeriod.EOF
            If recPeriod!strPeriod < strMinPeriod Then
                recPeriod.MoveNext
            Else
                Exit Do
            End If
        Loop
        recItem.Close
        
        mstrFirstPeriod = strMinCalcPeriod
        With cboCost(0)
            .Clear
        End With
        Do While Not recPeriod.EOF
            cboCost(0).AddItem recPeriod!strPeriod
            recPeriod.MoveNext
        Loop
        If strDefaultPeriod = "" Then
            strDefaultPeriod = gclsBase.AccountYear & "年" & Format(gclsBase.Period, "00") & "期末"
        End If
        For intCnt = 0 To cboCost(0).ListCount - 1
            If cboCost(0).list(intCnt) = strDefaultPeriod Then
                cboCost(0).ListIndex = intCnt
                Exit For
            End If
        Next intCnt
    End If
    recPeriod.Close
End Sub

'查找商品用到的所有成本计算方法
Private Sub InitMethod()
    Dim strSql As String
    Dim recMethod As rdoResultset

    cboCost(1).Clear
    
    strSql = "SELECT DISTINCT strCostMethod FROM ItemNature WHERE strItemCategory='1' AND strCostMethod>'0'"
    Set recMethod = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recMethod.EOF Then
        Do While Not recMethod.EOF
            cboCost(1).AddItem MethodName(recMethod!strCostMethod)
            recMethod.MoveNext
        Loop
    Else
        cboCost(1).AddItem MethodName(cmFIFO)
    End If
    recMethod.Close
    Set recMethod = Nothing
End Sub

'计算全部商品的成本(也可按成本方法分别计算)
Private Function CalcAllCost(Optional strMethodCode As String, Optional blnFlash As Boolean) As Boolean
    Dim strPeriod As String, strEndPeriod As String
    Dim dtmStart As Date, dtmEnd As Date
    Dim errNo As Long, lngCostAdjust As Long
    Dim blnSucceed As Boolean
    Dim strSql As String
    Dim lngErrItemID As Long
    Dim strErrMsg  As String
    Dim rtfQuery As rdoQuery
    
    On Error GoTo ErrHandle
    
'    If Not ExclusiveIn("成本计算", -1, "不能计算成本,因为有其他用户也在使用该帐套") Then
'        Exit Function
'    End If
    
    '重新计算成本开始计算日期
    strPeriod = cboCost(0).Text
    InitDate strPeriod
    lngCostAdjust = GetSet(1, "成本计算", "调整成本", 1)
    If lngCostAdjust <> 1 Then lngCostAdjust = 0
    
    strEndPeriod = TostrPeriod(CDate(CalDate.Text))
    gclsBase.DateOfPeriod GetintYear(strEndPeriod), GetbytPeriod(strEndPeriod), dtmStart
    dtmEnd = CDate(CalDate.Text)
    
    '检查是否有本期结转成本凭证,若有则删除或冲销
    If Not CheckCostVoucher(mstrFirstPeriod, strEndPeriod) Then
        MousePointer = vbDefault
        Exit Function
    End If
    
    '是否所有加工已结算
    If Not EntrustInFromOut(dtmEnd) Then
        MousePointer = vbDefault
        Exit Function
    End If
    
    strPeriod = mstrFirstPeriod
    If strPeriod > strEndPeriod Then strPeriod = strEndPeriod
    
    MsgForm.PleaseWait "正在计算，请稍后..."
    SaveSet 1, "成本计算", "红字成本_" & cboCost(1).Text, cboCost(2).Text, True, "String"
    
    blnSucceed = True
    CalcAllCost = True
    Do While strPeriod <= strEndPeriod
        gclsBase.DateOfPeriod GetintYear(strPeriod), GetbytPeriod(strPeriod), dtmStart, dtmEnd
        
        If Not ClearActivityVoucher(dtmStart, dtmEnd) Then
            MousePointer = vbDefault
            blnSucceed = False
            Exit Do
        ElseIf Not ChoiceAmt(strEndPeriod) Then
            MousePointer = vbDefault
            blnSucceed = False
            Exit Do
        End If
    
        Set rtfQuery = gclsBase.BaseDB.CreateQuery("", "{?=CALL " & gclsBase.UID & ".CalcCost(?,?,?,?,?)}")
        rtfQuery.rdoParameters(0).Type = rdTypeVARCHAR
        rtfQuery.rdoParameters(1).Type = rdTypeINTEGER
        rtfQuery.rdoParameters(2).Type = rdTypeINTEGER
        rtfQuery.rdoParameters(3).Type = rdTypeINTEGER
        rtfQuery.rdoParameters(4).Type = rdTypeINTEGER
        rtfQuery.rdoParameters(5).Type = rdTypeINTEGER
'        rtfQuery.rdoParameters(0).Direction = rdParamOutput
        rtfQuery.rdoParameters(1).Direction = rdParamInput
        rtfQuery.rdoParameters(2).Direction = rdParamInput
        rtfQuery.rdoParameters(3).Direction = rdParamInput
        rtfQuery.rdoParameters(4).Direction = rdParamInput
        rtfQuery.rdoParameters(5).Direction = rdParamInput
        rtfQuery.rdoParameters(1).Value = CLng(GetintYear(strPeriod))
        rtfQuery.rdoParameters(2).Value = CLng(GetbytPeriod(strPeriod))
        rtfQuery.rdoParameters(3).Value = CLng(gclsBase.OperatorID)
        rtfQuery.rdoParameters(4).Value = CLng(IIf(blnFlash, 1, 0))
        rtfQuery.rdoParameters(5).Value = lngCostAdjust
        rtfQuery.Execute
        lngErrItemID = C2lng(rtfQuery.rdoParameters(0).Value)
        If lngErrItemID <> 0 Then
            rtfQuery.Close
            Set rtfQuery = Nothing
            CalcAllCost = False
            Exit Do
        End If
        rtfQuery.Close
        Set rtfQuery = Nothing
        
        strPeriod = AddstrPeriod(strPeriod)
        If strPeriod = "" Then Exit Do
    Loop
    gclsSys.SendMessage Me.hwnd, msgReceipt22
    Unload MsgForm
    If blnSucceed Then
        If Not CalcAllCost Then
            ShowMsg hwnd, IIf(lngErrItemID > 0, "商品“" & ItemName(lngErrItemID), "") & "”成本计算不成功：" & GetErrMsg(), vbOKOnly + vbCritical, Caption
        Else
            ShowMsg hwnd, "成本计算完毕！", vbOKOnly + vbInformation, Caption
        End If
    End If
    Exit Function
    
ErrHandle:
    Unload MsgForm
    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
    prgLoad.Visible = False
    MousePointer = vbDefault
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        控件 事件、方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cboCost_Click(Index As Integer)
    Select Case Index
    Case 0 '日期
        DateClick
    Case 1 '计算方法
        MethodClick
    Case 2 '红字成本方法
        If Not mblnRefresh Then
            SaveSet 1, "成本计算", "红字成本_" & cboCost(1).Text, cboCost(2).Text, True, "String"
        End If
    Case 3 '查找
        SortClick
    End Select
End Sub

Private Sub cboCost_DropDown(Index As Integer)
    Select Case Index
    Case 0 '日期
        If cboCost(0).ListCount <= 1 Then
            InitDate
        End If
    Case 1 '计算方法
    Case 2 '红字成本方法
    Case 3 '查找
    End Select
End Sub

Private Sub chkTax_Click()
    '保存设置
    SaveSet 1, "成本计算", "是否含税", chkTax.Value, True, "Long"
    mclsMainControl_ToolRefresh
End Sub

Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
End Sub

'刷新商品列表