📄 frmsalaryfomularset.frm
字号:
Left = 6255
TabIndex = 22
Top = 900
UseMaskColor = -1 'True
Width = 1210
End
Begin VB.CommandButton cmdSalaryFormula
Caption = "删除公式(&D)"
Height = 350
Index = 1
Left = 6255
TabIndex = 23
Top = 1245
UseMaskColor = -1 'True
Width = 1210
End
Begin MSFlexGridLib.MSFlexGrid msgSalaryFormula
Height = 1500
Index = 1
Left = 1365
TabIndex = 17
Top = 3795
Width = 3015
_ExtentX = 5318
_ExtentY = 2646
_Version = 393216
Rows = 1
Cols = 5
FixedRows = 0
FixedCols = 0
BackColorFixed = 12632256
BackColorBkg = -2147483643
GridColor = 16777215
GridColorFixed = 16777215
AllowBigSelection= 0 'False
FocusRect = 0
GridLines = 0
GridLinesFixed = 0
ScrollBars = 2
SelectionMode = 1
Appearance = 0
FormatString = " ||||"
End
Begin MSFlexGridLib.MSFlexGrid msgSalaryFormula
Height = 3405
Index = 0
Left = 45
TabIndex = 0
Top = 120
Width = 6135
_ExtentX = 10821
_ExtentY = 6006
_Version = 393216
Cols = 10
FixedCols = 0
BackColorFixed = -2147483644
ForeColorFixed = -2147483641
ForeColorSel = -2147483643
BackColorBkg = -2147483643
GridColor = -2147483644
GridColorFixed = -2147483643
FocusRect = 0
GridLines = 0
ScrollBars = 2
FormatString = " 项目 | 计算公式 | 计算条件 |||"
End
Begin VB.Label lblSalaryFomular
BackStyle = 0 'Transparent
Caption = "项目："
Height = 255
Index = 1
Left = 1365
TabIndex = 16
Top = 3570
Width = 855
End
Begin VB.Label lblSalaryFomular
BackStyle = 0 'Transparent
Caption = "项目值："
Height = 255
Index = 0
Left = 4485
TabIndex = 18
Top = 3570
Width = 1335
End
End
Attribute VB_Name = "frmSalaryFomularSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'工资公式设置
'
'功能：设置工资公式
'
'作者：唐吉禹
'
'1998-6-28
'
'工资公式GRID的列：计算项目说明，计算公式说明，计算条件说明，计算项目，
'计算公式，计算条件，校验是否通过，计算函数条件，计算函数表。
'
Option Explicit
Private mintSalaryViewID As Long
Private mlngSalaryID As Long '工资目录表ID
Private WithEvents mclsDepoland As DepolandClass
Attribute mclsDepoland.VB_VarHelpID = -1
Private mblnCond As Boolean
Private mblnFomulaOk As Boolean '公式校验成功否
Private WithEvents mclsSubClass32 As SubClass32.SubClass
Attribute mclsSubClass32.VB_VarHelpID = -1
Private mblnDelete As Boolean '删除公式
Private mblnChangList As Boolean '改变行顺序
Private mblnWriteCbo As Boolean '写工资项目否
Private mstrNowZeroName As String
Private mstrNowTaxName As String
Private mstrLastZeroName As String
Private mstrFormulaItemname As String '工资公式项目名称
Private mlngDeductFieldID As Long '扣零项目ID
Private mlngTaxFieldID As Long '扣税项目ID
Private mdblDeductLevel As Double '扣零级别
Private mlngDeductPutFieldID As Long '扣零发放项目ID
Private mblnIsTax As Boolean '扣税否
Private mblnIsInit As Boolean '初始化否
Private mstrSql As String
Private mblnIsOK As Boolean '是否为确定退出
Private Sub Check_Fomula()
Dim strFormula As String '公式
Dim strCond As String '条件
Dim strSql As String
Dim qrfSalary As rdoQuery '工资数据表
Dim blnIsError As Boolean '出错否
Dim recSalaryTry As rdoResultset '测试公式Rec
Dim strDateFunTmp1 As String
Dim strDateFunTmp2 As String
With msgSalaryFormula(0)
mblnFomulaOk = False
'strSql = "SELECT strTableName,strFieldType,lngViewFieldID FROM ViewField WHERE ViewField.lngViewID" _
& "=63 AND TRIM(ViewField.strViewFieldDesc)='" & Trim(.TextMatrix(.Row, 0)) & "'"
strSql = "SELECT strTableName,strFieldType,lngViewFieldID FROM ViewField WHERE ViewField.lngViewID" _
& "=63 AND LTRIM(RTRIM(ViewField.strViewFieldDesc))='" & Trim(.TextMatrix(.Row, 0)) & "'"
Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If recSalaryTry.EOF Then
ShowMsg Me.hWnd, "计算项目：" & Trim(.TextMatrix(.Row, 0)) & "不存在。", vbInformation, Me.Caption
If UCase(.TextMatrix(.Row, 4)) <> "CALCZERO" And UCase(.TextMatrix(.Row, 4)) <> "CALCTAX" _
And UCase(.TextMatrix(.Row, 4)) <> "PUTZERO" Then
cboFormula.Visible = True
cboFormula.SetFocus
End If
Exit Sub
End If
If UCase(Trim(recSalaryTry!strTableName)) = "SALARY" And UCase(Trim(recSalaryTry!strFieldType)) = "DOUBLE" Then
.TextMatrix(.Row, 3) = recSalaryTry!lngViewFieldID
Else
ShowMsg Me.hWnd, "项目：" & Trim(.TextMatrix(.Row, 0)) & "为不可计算项目。", vbInformation, Me.Caption
If UCase(.TextMatrix(.Row, 4)) <> "CALCZERO" And UCase(.TextMatrix(.Row, 4)) <> "CALCTAX" _
And UCase(.TextMatrix(.Row, 4)) <> "PUTZERO" Then
cboFormula.Visible = True
cboFormula.SetFocus
End If
Exit Sub
End If
recSalaryTry.Close
Set recSalaryTry = Nothing
'存回Txt到Grid
Select Case .col
Case 0
Case 1
.col = 4
.col = 1
Case 2
.col = 5
.col = 2
End Select
'调用公式校验
strFormula = .TextMatrix(.Row, 1)
If Len(Trim(.TextMatrix(.Row, 1))) > 0 And Trim(.TextMatrix(.Row, 0)) <> "" Then
Select Case Trim(.TextMatrix(.Row, 0))
'本次扣零
Case mstrNowZeroName
If InStr(strFormula, "扣零计算") <> 1 Then
ShowMsg Me.hWnd, "扣零计算公式设置有误。", vbInformation, Me.Caption
Exit Sub
End If
'代扣税额
Case mstrNowTaxName
If InStr(strFormula, "扣税计算") <> 1 Then
ShowMsg Me.hWnd, "扣税计算公式设置有误。", vbInformation, Me.Caption
Exit Sub
End If
End Select
'扣零、扣税计算判断,CalcZero,CalcTax
strFormula = Trim(.TextMatrix(.Row, 1))
If InStr(strFormula, "扣零计算") > 0 Then
Call ZeroTaxFunc("扣零计算", strFormula)
Exit Sub
End If
If InStr(strFormula, "扣税计算") > 0 Then
Call ZeroTaxFunc("扣税计算", strFormula)
Exit Sub
End If
'统计函数或发放扣零校验
.TextMatrix(.Row, 6) = "0"
If .TextMatrix(.Row, 9) <> "1" Then
'校验公式
mblnCond = False
mblnFomulaOk = True
'判断不存在关系运算符
If InStr(.TextMatrix(.Row, 1), "=") > 0 Or InStr(.TextMatrix(.Row, 1), ">") > 0 Or _
InStr(.TextMatrix(.Row, 1), "<") > 0 Or InStr(.TextMatrix(.Row, 1), "<>") > 0 _
Or InStr(.TextMatrix(.Row, 1), " 并且 ") > 0 Or _
InStr(.TextMatrix(.Row, 1), " 或者 ") > 0 Or InStr(.TextMatrix(.Row, 1), " 且 ") > 0 _
Or InStr(.TextMatrix(.Row, 1), " 或 ") > 0 Then
mblnFomulaOk = False
ShowMsg Me.hWnd, "计算公式不能含有：'=','>','<','<>','并且','或者','且','或'。", _
vbInformation, Me.Caption
End If
Else
mblnFomulaOk = True
End If
If mblnFomulaOk = True Then
If .TextMatrix(.Row, 9) <> "1" Then
'替换运算符
strFormula = Trim(.TextMatrix(.Row, 1))
'替换回车
strFormula = Salary.Change_Text(Chr(13), " ", strFormula)
strFormula = Salary.Change_Text(Chr(10), " ", strFormula)
'替换Ctrl+I
strFormula = Salary.Change_Text(Chr(9), " ", strFormula)
'替换除号
strFormula = Salary.Change_Text("÷", "/", strFormula)
'替换乘号
strFormula = Salary.Change_Text("×", "*", strFormula)
'替换减号
Analysis strFormula
'通过校验
If mblnFomulaOk Then
'取出公式
mclsDepoland.GetFomular strFormula
End If
End If
'校验条件
If Len(Trim(.TextMatrix(.Row, 2))) > 0 Then
mblnCond = True
'替换运算符
strCond = .TextMatrix(.Row, 2)
'替换回车
strCond = Salary.Change_Text(Chr(13), " ", strCond)
strCond = Salary.Change_Text(Chr(10), " ", strCond)
'替换Ctrl+I
strCond = Salary.Change_Text(Chr(9), " ", strCond)
'替换除号
strCond = Salary.Change_Text("÷", "/", strCond)
'替换乘号
strCond = Salary.Change_Text("×", "*", strCond)
'替换等号
strCond = Salary.Change_Text("＝", "=", strCond)
Analysis strCond
'通过校验
If mblnFomulaOk Then
'取出公式
mclsDepoland.GetFomular strCond
'根据关键字IN删除等号，如：部门名称='生产部'而'生产部'为非末级部门时，先在
'mclsDepoland_OnAccidenceParse中将'生产部'替换为：IN('一车间','二车间')。(其中'一车间'
','二车间'为'生产部'的下级明细部门)则公式变为：部门名称=IN('一车间','二车间')，
'多出一个等号。ChangIN的功能是将多出的等号删除。计算条件中包含"IN('
'"系统认为可能多出一个等号
'将紧靠前的"="删除
Call Salary.ChangeIN(strCond)
.TextMatrix(.Row, 6) = "1" '公式确认
Else
.TextMatrix(.Row, 6) = ""
End If
Else
If mblnFomulaOk Then
.TextMatrix(.Row, 6) = "1" '公式确认
Else
.TextMatrix(.Row, 6) = ""
End If
End If
If .TextMatrix(.Row, 6) = "1" Then
'写回英文公式
On Error GoTo Errors
blnIsError = False
'计算公式
If .TextMatrix(.Row, 9) <> "1" Then
strDateFunTmp1 = ""
strDateFunTmp2 = ""
strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strFormula, strDateFunTmp2)
strSql = "SELECT " & strDateFunTmp1 & " AS dblValue FROM SalaryData"
If strDateFunTmp2 <> "" Then
strSql = strSql & " WHERE " & strDateFunTmp2
End If
'strSql = "SELECT " & strFormula & " AS dblValue FROM SalaryData"
Else '计算函数，只校验条件
strSql = "SELECT * FROM SalaryData"
End If
If Len(Trim(strCond)) > 0 Then
strDateFunTmp1 = ""
strDateFunTmp2 = ""
strDateFunTmp1 = Salary.GetOraDateFunnctionCalc(strCond, strDateFunTmp2)
If InStr(UCase(strSql), "WHERE") > 0 Then
strSql = strSql & " AND " & strDateFunTmp1
Else
strSql = strSql & " WHERE " & strDateFunTmp1
End If
If strDateFunTmp2 <> "" Then
strSql = strSql & " AND " & strDateFunTmp2
End If
End If
blnIsError = False
Set recSalaryTry = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
If Not blnIsError Then
If .TextMatrix(.Row, 9) <> "1" Then
.TextMatrix(.Row, 4) = strFormula
End If
.TextMatrix(.Row, 5) = strCond
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -