企业管理

开发平台：
Visual Basic

+：源码内容
							VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form JC_FrmFormulaGen 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "公式定义"
   ClientHeight    =   5790
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8280
   Icon            =   "基础设置_公式定义.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5790
   ScaleWidth      =   8280
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Height          =   5775
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   8265
      Begin VB.TextBox txtDescribe 
         Height          =   1605
         Left            =   120
         Locked          =   -1  'True
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   13
         Top             =   420
         Width           =   3495
      End
      Begin VB.Frame Frame2 
         Caption         =   "公式参照"
         Height          =   3165
         Left            =   60
         TabIndex        =   5
         Top             =   2070
         Width           =   8115
         Begin VB.OptionButton Opt_List 
            Caption         =   "核算对象"
            Height          =   180
            Index           =   3
            Left            =   7020
            TabIndex        =   14
            Top             =   240
            Width           =   1035
         End
         Begin VB.ListBox lstFunction 
            Height          =   2580
            Left            =   90
            TabIndex        =   11
            Top             =   480
            Width           =   3465
         End
         Begin VB.OptionButton Opt_List 
            Caption         =   "会计科目"
            Height          =   180
            Index           =   1
            Left            =   4740
            TabIndex        =   9
            Top             =   240
            Width           =   1035
         End
         Begin VB.OptionButton Opt_List 
            Caption         =   "来源部门"
            Height          =   180
            Index           =   2
            Left            =   5880
            TabIndex        =   8
            Top             =   240
            Width           =   1035
         End
         Begin VB.OptionButton Opt_List 
            Caption         =   "物料编码"
            Height          =   180
            Index           =   0
            Left            =   3600
            TabIndex        =   7
            Top             =   240
            Value           =   -1  'True
            Width           =   1035
         End
         Begin MSComctlLib.TreeView Tree_List 
            Height          =   2580
            Left            =   3600
            TabIndex        =   6
            Top             =   480
            Width           =   4425
            _ExtentX        =   7805
            _ExtentY        =   4551
            _Version        =   393217
            Style           =   7
            Appearance      =   1
         End
         Begin VB.Label Label2 
            AutoSize        =   -1  'True
            Caption         =   "函数名称:"
            Height          =   180
            Left            =   90
            TabIndex        =   10
            Top             =   240
            Width           =   810
         End
      End
      Begin VB.TextBox txtFormula 
         Height          =   1605
         Left            =   3660
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   3
         Top             =   420
         Width           =   4515
      End
      Begin VB.CommandButton CancelButton 
         Caption         =   "取消"
         Height          =   375
         Left            =   6900
         TabIndex        =   2
         Top             =   5310
         Width           =   1275
      End
      Begin VB.CommandButton OKButton 
         Caption         =   "公式确认"
         Height          =   375
         Left            =   5460
         TabIndex        =   1
         Top             =   5310
         Width           =   1275
      End
      Begin VB.Label Lab_NonceItem 
         AutoSize        =   -1  'True
         ForeColor       =   &H000000FF&
         Height          =   180
         Left            =   2010
         TabIndex        =   16
         Top             =   5407
         Width           =   90
      End
      Begin VB.Label Lab_NonceCenter 
         AutoSize        =   -1  'True
         ForeColor       =   &H000000FF&
         Height          =   180
         Left            =   180
         TabIndex        =   15
         Top             =   5400
         Width           =   90
      End
      Begin VB.Label Label3 
         Caption         =   "函数说明:"
         Height          =   195
         Left            =   120
         TabIndex        =   12
         Top             =   180
         Width           =   735
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "公式内容:"
         Height          =   180
         Left            =   3660
         TabIndex        =   4
         Top             =   180
         Width           =   810
      End
   End
End
Attribute VB_Name = "JC_FrmFormulaGen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************************************************************************
'*    模 块 名 称 :公式定义
'*    功 能 描 述 :公式定义
'*    程序员姓名  :xjl
'*    最后修改人  :xjl
'*    最后修改时间:2002/1/22
'*    备        注:程序中所有依实际情况自定义部分均用[>>  <<]括起
'*********************************************************************************************************
Option Explicit
Dim str_Describe() As String
Dim str_ConSult_List() As String
Private Sub CancelButton_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    txtFormula.Text = Glo_FormulaString
    FillListBox
    Call ConSult_List(0)
    '显示成本中心,成本项目
    Lab_NonceCenter = "成本中心:《" + Glo_NonceCenter + "》"
    Lab_NonceItem = "成本项目:《" + Glo_NonceItem + "》"
    Lab_NonceItem.Left = Lab_NonceCenter.Left + Lab_NonceCenter.Width + 50
End Sub
Private Sub lstFunction_Click()
    txtDescribe.Text = str_Describe(lstFunction.ListIndex)
End Sub
Private Sub lstFunction_DblClick()
    txtFormula.SelText = lstFunction.Text
End Sub
Private Sub OKButton_Click()
    Dim Tsxx As String
    If Trim(txtFormula.Text) = "" Then
        txtFormula.Text = "0"
    End If
    '公式检验
    If CheckFormula = False Then
        Tsxx = "公式语法有误,请重新输入!"
        txtFormula.SetFocus
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    Glo_FormulaString = txtFormula.Text
    Unload Me
End Sub
Function FillListBox() As String   '填充列表框并定位
    '函数参数：列表框，列表框分组编码，定位内容,填充类型(0-无空记录  1-有空记录(1个空格) )
    Dim Lbknrrec As ADODB.Recordset
    Dim int_Count As Integer
    '填充列表框内容
    Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select * from cwzz_UserDefineFn")
    ReDim str_Describe(Lbknrrec.RecordCount - 1) As String
    Do While Not Lbknrrec.EOF
        lstFunction.AddItem Trim(Lbknrrec("fnalias") & "")
        str_Describe(int_Count) = Trim(Lbknrrec("fncomment") & "")
        int_Count = int_Count + 1
        Lbknrrec.MoveNext
    Loop
    '定位列表框内容
    lstFunction.ListIndex = 0
End Function
'物料,科目,部门参照,成本对象
Sub ConSult_List(Index As Integer)
    Dim RecTemp As ADODB.Recordset
    Dim Description  As String
    Dim SQLStr As String
    Select Case Index
        Case 0
            SQLStr = "Select MNumber As A,MName As B,'1' As CodeLevel From kf_V_invsort where InvSortcode like '01'"
            Description = "物料编码"
        Case 1
            SQLStr = "Select Ccode AS A,Cname AS B,CodeLevel From Cwzz_AccCode Order By CCode"
            Description = "科目编码"
        Case 2
            SQLStr = "Select DeptCode As A,DeptName AS B,CodeLevel From Gy_Department Order By DeptCode"
            Description = "来源部门"
        Case 3
            SQLStr = "Select ObjectCode As A,ObjectName As B,'1' As CodeLevel From Cb_CostObject Order By ObjectCode"
            Description = "核算对象"
    End Select
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SQLStr)
    Call fill_tv(Tree_List, RecTemp, "A", "B", True, Description)
End Sub
Private Sub Opt_List_Click(Index As Integer)
    Call ConSult_List(Index)
End Sub
'---------------------------------------------
'填充TREEVIEW
Public Sub fill_tv(tv As TreeView, flbm As ADODB.Recordset, field1 As String, field2 As String, bmjc_bz As Boolean, tree_name As String)
    Dim Title_Bar As String
    Title_Bar = "成本核算管理系统"
    Dim fllb, lsbl(), lsbl1(), remlayer, nodX, tem, count
    On Error GoTo ERRORCL
    tv.Nodes.Clear
    flbm.Requery
    If flbm.EOF Then
        Set nodX = tv.Nodes.Add(, 4, "r", tree_name)
        Exit Sub
    Else
        Set nodX = tv.Nodes.Add(, 4, "r", tree_name)
    End If
    flbm.MoveFirst
    count = 1
    If bmjc_bz Then
        Do While Not flbm.EOF
            fllb = "(" + Trim(flbm.Fields(field1)) + ")" + Trim(flbm.Fields(field2))
            remlayer = flbm.Fields("codelevel")
            tem = Trim(flbm.Fields(field1))
            Select Case remlayer
                Case 1
                    ReDim Preserve lsbl(remlayer)
                    ReDim Preserve lsbl1(remlayer)
                    lsbl(remlayer) = "p" & tem
                    Set nodX = tv.Nodes.Add("r", 4, lsbl(remlayer), fllb)
                    tv.Nodes(count).Expanded = True
                Case 2
                    ReDim Preserve lsbl1(remlayer)
                    ReDim Preserve lsbl1(remlayer)
                    lsbl1(remlayer) = "p" & tem
                    Set nodX = tv.Nodes.Add(lsbl(remlayer - 1), tvwChild, lsbl1(remlayer), fllb)
                Case 3
                    ReDim Preserve lsbl(remlayer)
                    ReDim Preserve lsbl1(remlayer)
                    lsbl(remlayer) = lsbl1(remlayer - 1)
                    lsbl1(remlayer) = "p" & tem
                    Set nodX = tv.Nodes.Add(lsbl(remlayer), tvwChild, lsbl1(remlayer), fllb)
                Case Else
                    ReDim Preserve lsbl(remlayer)
                    ReDim Preserve lsbl1(remlayer)
                    lsbl(remlayer) = lsbl1(remlayer - 1)
                    lsbl1(remlayer) = "p" & tem
                    Set nodX = tv.Nodes.Add(lsbl(remlayer), tvwChild, lsbl1(remlayer), fllb)
            End Select
            count = count + 1
            flbm.MoveNext
        Loop
    Else
        Do While Not flbm.EOF
            fllb = "(" + Trim(flbm.Fields(field1)) + ")" + Trim(flbm.Fields(field2))
            tem = Trim(flbm.Fields("flbm"))
            lsbl(remlayer) = "p" & tem
            Set nodX = tv.Nodes.Add(, 4, lsbl(remlayer), fllb)
            flbm.MoveNext
        Loop
    End If
    Exit Sub
ERRORCL:
    MsgBox "程序出现错误", vbExclamation, Title_Bar
    Exit Sub
End Sub
''双击事件
Private Sub Tree_List_DblClick()
    txtFormula.SelText = Mid(Tree_List.SelectedItem.Key, 2, Len(Tree_List.SelectedItem.Key) - 1)
End Sub
'公式检验
Function CheckFormula() As Boolean
    Dim Str_Formula As String
    Dim Cxnrrec As New ADODB.Recordset
    Dim SQLStr
    On Error GoTo Err:
    '公式
    Str_Formula = Trim(txtFormula.Text)
    Str_Formula = Fn_Replace(Str_Formula, 0)
    '替换年月
    Str_Formula = Replace(Str_Formula, "本年", Xtyear)
    Str_Formula = Replace(Str_Formula, "本月", Xtmm)
    SQLStr = "Select " & Str_Formula & " As ReturnValue"
    
    Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SQLStr)
    CheckFormula = True
    Exit Function
Err:
    CheckFormula = False
End Function

						