📄 +
字号:
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -