VB开发的ERP系统

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)