企业管理

开发平台：
Visual Basic

：源码内容
							VERSION 5.00
Begin VB.Form JS_FrmSelectObject 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "成本对象"
   ClientHeight    =   1755
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5250
   Icon            =   "成本计算_选择成本对象.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1755
   ScaleWidth      =   5250
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Caption         =   "选择成本对象"
      Height          =   1635
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   5115
      Begin VB.ComboBox Combo_CostObject 
         Height          =   300
         Left            =   1170
         Style           =   2  'Dropdown List
         TabIndex        =   3
         Top             =   480
         Width           =   3705
      End
      Begin VB.CommandButton Cmd_Cancel 
         Caption         =   "取消(&C)"
         Height          =   300
         Left            =   3750
         TabIndex        =   2
         Top             =   1020
         Width           =   1120
      End
      Begin VB.CommandButton Cmd_Enter 
         Caption         =   "确定(&O)"
         Height          =   300
         Left            =   2580
         TabIndex        =   1
         Top             =   1020
         Width           =   1120
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "成本对象:"
         Height          =   180
         Left            =   300
         TabIndex        =   4
         Top             =   540
         Width           =   810
      End
   End
End
Attribute VB_Name = "JS_FrmSelectObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************************
'*    模 块 名 称 :对象选择
'*    功 能 描 述 :对象选择
'*    程序员姓名  :xjl
'*    最后修改人  :xjl
'*    最后修改时间:2002/1/22
'*    备        注:
'*******************************************************
Dim Combo_CostObjectCode() As String        '成本对象
Dim IsCombo As Boolean
Dim Str_ObjectCode As String                '对象编码
Dim Str_ObjectName As String                '对象名称
Private Sub Cmd_Cancel_Click()                  '取消
    Unload Me
End Sub
Private Sub Cmd_Enter_Click()                   '确定
    '成本归集
    If JS_FrmSelectObject.Combo_CostObject.Tag = "Gather" Then
        If Combo_CostObject.ListCount <= 0 Then
            Unload Me
            Exit Sub
        End If
        Str_ObjectCode = Trim(Combo_CostObjectCode(Combo_CostObject.ListIndex))
        Str_ObjectName = Trim(Combo_CostObject.List(Combo_CostObject.ListIndex))
        Unload Me
        Call CostGather                         '成本归集
        Str_ObjectCode = ""
        IsCombo = False
    End If
    
    '成本分配
    If JS_FrmSelectObject.Combo_CostObject.Tag = "Scatter" Then
        If Combo_CostObject.ListCount <= 0 Then
            Unload Me
            Exit Sub
        End If
        Str_ObjectCode = Trim(Combo_CostObjectCode(Combo_CostObject.ListIndex))
        Str_ObjectName = Trim(Combo_CostObject.List(Combo_CostObject.ListIndex))
        Unload Me
        Call CostScatter                        '成本分配
        Str_ObjectCode = ""
        IsCombo = False
    End If
End Sub
Private Sub Form_Load()                         '启动
    If IsCombo = True Then
        Exit Sub
    End If
    Call CshCostObject
End Sub
Sub CostGather()                                '成本归集
    
    Dim SqlStr As String                        'SQL字符
    Dim Rec_CostGather As New ADODB.Recordset   '临时记录集
    Dim Str_Formula As String                   '临时字符串
    Dim yhAnswer As Integer                     '提示返回值
    Dim RecTemp As New ADODB.Recordset          '临时记录集
    Dim Quantity As Double                      '数量
    Dim Cash As Currency                        '金额
    Dim Tsxx As String                          '提示信息
    IsCombo = True
    Tsxx = "是否确认归集成本对象《" + Str_ObjectName + "》的数据?"
    yhAnswer = Xtxxts(Tsxx, 2, 2)
    If yhAnswer = 2 Then
        Exit Sub
    End If
    
    Xt_Wait.Show
    Xt_Wait.Refresh
    Screen.MousePointer = 11
    
    On Error GoTo Err:
    Cw_DataEnvi.DataConnect.BeginTrans
    
    SqlStr = "Select * From Cb_GatherSet A Inner Join " _
                & "Cb_CostStructure B On A.CenterCode=b.CenterCode And A.ItemCode=B.ItemCode And ObjectCode='" + Str_ObjectCode + "'"
    
    Set Rec_CostGather = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    
    Cw_DataEnvi.DataConnect.Execute "Delete From Cb_CostGather  " _
            & "Where Year=" + CStr(Glo_Year) + " And Period=" + CStr(Glo_Period) + " And Ltrim(CenterCode)+Rtrim(ItemCode) In (Select Ltrim(A.CenterCode)+Rtrim(A.ItemCode) From Cb_GatherSet A Inner Join " _
                & "Cb_CostStructure B On A.CenterCode=b.CenterCode And A.ItemCode=B.ItemCode And ObjectCode='" + Str_ObjectCode + "')"
            
    Do Until Rec_CostGather.EOF
        
        '计算数量
        Str_Formula = Trim(Rec_CostGather.Fields("QuGatherFormula"))
        If Str_Formula <> "" Then
            Str_Formula = Fn_Replace(Str_Formula, 0)
            '年月替换
            Str_Formula = Replace(Str_Formula, "本年", Glo_Year)
            Str_Formula = Replace(Str_Formula, "本月", Glo_Period)
            SqlStr = "Select " & Str_Formula & " As ReturnValue"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not RecTemp.EOF Then
                Quantity = IIf(IsNull(RecTemp.Fields("ReturnValue")), 0, RecTemp.Fields("ReturnValue"))
            Else
                Quantity = 0
            End If
        Else
            Quantity = 0
        End If
        
        '计算金额
        Str_Formula = Trim(Rec_CostGather.Fields("MoGatherFormula"))
        If Str_Formula <> "" Then
            Str_Formula = Fn_Replace(Str_Formula, 0)
            '年月替换
            Str_Formula = Replace(Str_Formula, "本年", Glo_Year)
            Str_Formula = Replace(Str_Formula, "本月", Glo_Period)
            SqlStr = "Select " & Str_Formula & " As ReturnValue"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not RecTemp.EOF Then
                Cash = IIf(IsNull(RecTemp.Fields("ReturnValue")), 0, RecTemp.Fields("ReturnValue"))
            Else
                Cash = 0
            End If
        Else
            Cash = 0
        End If
        
        '写入数据
        If RecTemp.State = 1 Then RecTemp.Close
        RecTemp.Open "Select * From Cb_CostGather Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
        RecTemp.AddNew
        RecTemp.Fields("ItemCode") = Rec_CostGather.Fields("ItemCode")
        RecTemp.Fields("CenterCode") = Rec_CostGather.Fields("CenterCode")
        RecTemp.Fields("Year") = Glo_Year
        RecTemp.Fields("Period") = Glo_Period
        RecTemp.Fields("GatherQuantity") = Quantity
        RecTemp.Fields("GatherMoney") = Cash
        RecTemp.Update
        
        Rec_CostGather.MoveNext
    Loop
    
    Cw_DataEnvi.DataConnect.CommitTrans
    
    '显示数据
    Xt_Wait.Hide
    Screen.MousePointer = 0
    Exit Sub
Err:
    Screen.MousePointer = 0
    Cw_DataEnvi.DataConnect.RollbackTrans
End Sub
Sub CshCostObject()                             '初始化成本对象
    Dim RecTemp As New ADODB.Recordset
    SqlStr = "Select Objectcode As A,ObjectName As B From Cb_CostObject Order By Objectcode"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    ReDim Combo_CostObjectCode(RecTemp.RecordCount)
    Combo_CostObject.Clear
    Do Until RecTemp.EOF
        Combo_CostObject.AddItem "(" + Trim(RecTemp.Fields("A")) + ")" + RecTemp.Fields("B")
        Combo_CostObjectCode(Combo_CostObject.NewIndex) = RecTemp.Fields("A")
        RecTemp.MoveNext
    Loop
    
    If Combo_CostObject.ListCount >= 1 Then
        Combo_CostObject.ListIndex = 0
    End If
End Sub
Sub CostScatter()                               '成本分配
    Dim SqlStr As String                        'SQL字符
    Dim Rec_CostScatter As New ADODB.Recordset  '临时记录集
    Dim Str_Formula As String                   '临时字符串
    Dim yhAnswer As Integer                     '提示返回值
    Dim RecTemp As New ADODB.Recordset          '临时记录集
    Dim Quantity As Double                      '数量
    Dim Cash As Currency                        '金额
    Dim CalOrder As Integer
    Dim Tsxx As String
    
    IsCombo = True
    Tsxx = "是否确认分配成本对象《" + Str_ObjectName + "》的数据?"
    yhAnswer = Xtxxts(Tsxx, 2, 2)
    If yhAnswer = 2 Then
        Exit Sub
    End If
    
    Screen.MousePointer = 11
    On Error GoTo Err:
    Cw_DataEnvi.DataConnect.BeginTrans
    '判断是否能进行分配
    SqlStr = "Select Max(CalOrder) AS A  From Cb_CostObject Where ObjectCode In " _
                & "(Select ObjectCode From Cb_ObjectComplete Where Auditing='1')"
    
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If IsNull(RecTemp.Fields("A")) Or RecTemp.Fields("A") = 0 Then
        CalOrder = 1
    Else
        CalOrder = RecTemp.Fields("A") + 1
    End If
    
    SqlStr = "Select CalOrder As A From Cb_CostObject Where ObjectCode='" + Str_ObjectCode + "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    
    If CalOrder < RecTemp.Fields("A") Then
        Tsxx = "上级对象还未分配,请先分配上级对象!"
        Call Xtxxts(Tsxx, 0, 1)
        Screen.MousePointer = 0
        Exit Sub
    End If
    
    Xt_Wait.Show
    Xt_Wait.Refresh
    '删除存在的数据
    Cw_DataEnvi.DataConnect.Execute ("Delete From Cb_CostScatter Where ObjectCode='" & Str_ObjectCode & "' And Year='" & Glo_Year & "' And Period='" & Glo_Period & "'")
    '有分配公式的数据
    SqlStr = "Select * From Cb_ScatterSet Where ObjectCode='" + Str_ObjectCode + "'"
    Set Rec_CostScatter = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    
    Do Until Rec_CostScatter.EOF
        '计算数量
        Str_Formula = Trim(Rec_CostScatter.Fields("QuScatterFormula"))
        If Str_Formula <> "" Then
            Str_Formula = Fn_Replace(Str_Formula, 0)
            '年月替换
            Str_Formula = Replace(Str_Formula, "本年", Glo_Year)
            Str_Formula = Replace(Str_Formula, "本月", Glo_Period)
            SqlStr = "Select " & Str_Formula & " As ReturnValue"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not Cxnrrec.EOF Then
                Quantity = IIf(IsNull(Cxnrrec.Fields("ReturnValue")), 0, Cxnrrec.Fields("ReturnValue"))
            Else
                Quantity = 0
            End If
        Else
            Quantity = 0
        End If
        '计算金额
        Str_Formula = Trim(Rec_CostScatter.Fields("MoScatterFormula"))
        If Str_Formula <> "" Then
            Str_Formula = Fn_Replace(Str_Formula, 0)
            '年月替换
            Str_Formula = Replace(Str_Formula, "本年", Glo_Year)
            Str_Formula = Replace(Str_Formula, "本月", Glo_Period)
            SqlStr = "Select " & Str_Formula & " As ReturnValue"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not Cxnrrec.EOF Then
                Cash = IIf(IsNull(Cxnrrec.Fields("ReturnValue")), 0, Cxnrrec.Fields("ReturnValue"))
            Else
                Cash = 0
            End If
        Else
            Cash = 0
        End If
        '写入数据
        If RecTemp.State = 1 Then RecTemp.Close
        RecTemp.Open "Select * From Cb_CostScatter Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
        RecTemp.AddNew
        RecTemp.Fields("Objectcode") = Rec_CostScatter.Fields("ObjectCode")
        RecTemp.Fields("ItemCode") = Rec_CostScatter.Fields("ItemCode")
        RecTemp.Fields("CenterCode") = Rec_CostScatter.Fields("CenterCode")
        RecTemp.Fields("Year") = Glo_Year
        RecTemp.Fields("Period") = Glo_Period
        RecTemp.Fields("ScatterQuantity") = Quantity
        RecTemp.Fields("ScatterMoney") = Cash
        RecTemp.Update
        Rec_CostScatter.MoveNext
    Loop
    
    '无分配公式的数据
    SqlStr = "Select * From Cb_CostGather " _
            & "Where Year=" + CStr(Glo_Year) + " And Period=" + CStr(Glo_Period) + " And Ltrim(CenterCode)+Rtrim(ItemCode) In " _
            & "(Select Ltrim(A.CenterCode)+Rtrim(A.ItemCode) From Cb_GatherSet A " _
            & "Inner Join Cb_CostStructure B " _
            & "On A.CenterCode=b.CenterCode And A.ItemCode=B.ItemCode And ObjectCode='" + Str_ObjectCode + "') " _
            & "And Ltrim(CenterCode)+Rtrim(ItemCode) Not In " _
            & "(Select Ltrim(CenterCode)+Rtrim(ItemCode)  " _
            & "From Cb_CostScatter Where ObjectCode='" + Str_ObjectCode + "'   " _
            & "And Year=" + CStr(Glo_Year) + " And Period=" + CStr(Glo_Period) + ")"
    Set Rec_CostScatter = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    
    Do Until Rec_CostScatter.EOF
        If RecTemp.State = 1 Then RecTemp.Close
        RecTemp.Open "Select * From Cb_CostScatter Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
        RecTemp.AddNew
        RecTemp.Fields("Objectcode") = Str_ObjectCode
        RecTemp.Fields("ItemCode") = Rec_CostScatter.Fields("ItemCode")
        RecTemp.Fields("CenterCode") = Rec_CostScatter.Fields("CenterCode")
        RecTemp.Fields("Year") = Glo_Year
        RecTemp.Fields("Period") = Glo_Period
        RecTemp.Fields("ScatterQuantity") = 0
        RecTemp.Fields("ScatterMoney") = 0
        RecTemp.Update
        Rec_CostScatter.MoveNext
    Loop
    
    Call CostDataCollect                        '成本数据汇总
    Cw_DataEnvi.DataConnect.CommitTrans
    Xt_Wait.Hide
    Screen.MousePointer = 0
    Exit Sub
Err:
    Screen.MousePointer = 0
    Cw_DataEnvi.DataConnect.RollbackTrans
End Sub
Sub CostDataCollect()                           '成本数据汇总
    Dim DimYear As Integer
    Dim DimMM As Integer
    Dim CostThmonYcl As Double
    Dim CostTotalLjcl As Double
    DimMM = Glo_Period - 1
    If DimMM = 0 Then
        DimYear = Glo_Year - 1
        DimMM = 12
    Else
        DimYear = Glo_Year
    End If
    '求月产量,累计产量
    SqlStr = "Select Quantity From Cb_ObjectComplete Where ObjectCode='" + Str_ObjectCode + "'  " _
                & "And Year='" + CStr(Glo_Year) + "' And Period='" + CStr(Glo_Period) + "'"
                
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If Not RecTemp.EOF Then
        If IsNull(RecTemp.Fields("Quantity")) Then
            CostThmonYcl = 0
        Else
            CostThmonYcl = RecTemp.Fields("Quantity")
        End If
    Else
        CostThmonYcl = 0
    End If
    
    SqlStr = "Select Sum(Quantity) As CL From Cb_ObjectComplete Where ObjectCode='" + Str_ObjectCode + "'  " _
                    & "And Year='" + CStr(Glo_Year) + "' And Period<='" + CStr(Glo_Period) + "'"
                    
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If Not RecTemp.EOF Then
        If IsNull(RecTemp.Fields("CL")) Then
            CostTotalLjcl = 0
        Else
            CostTotalLjcl = RecTemp.Fields("CL")
        End If
    Else
        CostTotalLjcl = 0
    End If
    '对象编码,当前年,当前月,(当前年),(上一月),月产量,累计产量
    '对象明细表
    SqlStr = "Delete From Cb_Sccbb Where ObjectCode='" + Str_ObjectCode + "' And Year=" + CStr(Glo_Year) + " And  " _
                & "Period=" + CStr(Glo_Period) + " Insert Into Cb_Sccbb Select Objectcode,ItemCode,ParentCode,Year, " _
                & "Period,UnitCode,PlanUnitPrice,PlanQuantity,PlanMoney,PreMonAmount,PreMonMoney,ScatterQuantity, " _
                & "ScatterMoney,InvQuantity,InvValue,ThmonConsumeAmount,ThmonConsumeMoney,ThMonFactUnAmount, " _
                & "ThMonFactUnMoney,TotalConsumeAmount,TotalConsumeMoney,TotalConsumeUnAmount,TotalConsumeUnMoney, " _
                & "ThMonRatioAmount,ThMonRatioMoney,TotalRationAmount,TotalRationMoney,IsSum,IsShow From  " _
                & "Cb_Fn_Sccb('" + Str_ObjectCode + "'," + CStr(Glo_Year) + "," + CStr(Glo_Period) + ", " _
                & "" + CStr(DimYear) + "," + CStr(DimMM) + "," + CStr(CostThmonYcl) + "," + CStr(CostTotalLjcl) + ")"
    
    '本年累计数量
    '
    SqlStr = SqlStr + " Update Cb_ObjectComplete Set TotalQuantity=B.TotalQuantity,LYearAver=B.LYearAver, " _
                & "ThmonUnitCost=B.ThmonUnitCost,ThmonCost=B.ThmonCost,TotalCost=B.TotalCost,TYearAver=B.TYearAver " _
                & "From Cb_ObjectComplete A,Cb_Fn_CostCollect('" + Str_ObjectCode + "'," + CStr(Glo_Year) + ", " _
                & "" + CStr(Glo_Period) + ") B Where A.ObjectCode=B.ObjectCode And A.Year=B.Year And A.Period=B.Period  " _
                & "And A.ObjectCode='" + Str_ObjectCode + "' And A.Year=" + CStr(Glo_Year) + " And  " _
                & "A.Period=" + CStr(Glo_Period) + ""
                
    Cw_DataEnvi.DataConnect.Execute SqlStr
End Sub

						