+

VB开发的ERP系统

        End If
        
        s = "update PM_PayRoll set " & sUpdateField & "= " & FormulaSys & Chr(10) _
            & " from " & st & Chr(10) & " where PM_PayRoll.Period=0 "
        With Cw_DataEnvi.DataConnect
            .BeginTrans
                bBeginTrans = True
                .Execute (s)
            .RollbackTrans
        End With
    End If
    '验证正确，计算公式加 IsNull 函数
    FormulaSQL = GetFormulaSQL
    CheckFormula = True
    Set SC_Formula = Nothing
    Me.PB_CheckStatus.Visible = False
    bChecking = False
    
    Exit Function
    
ErrCtrl:
    Set SC_Formula = Nothing
    bChecking = False
    Me.PB_CheckStatus.Visible = False
    If bBeginTrans = True Then
        Cw_DataEnvi.DataConnect.RollbackTrans
    End If
    
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical

End Function

Public Function ResetPos(iPos As Integer)
  iPosSys = iPos
End Function

Public Function ResetPosOld(iPosSys As Integer)
  iPosOldSys = iPosSys
End Function

Private Sub Class_Initialize() '类初始化，包括初始化字段、公式、编码、操作符、其他等
    On Error GoTo ErrCtrl
    
    '初始化变量
    iPosSys = 1
    iPosOldSys = 1
    Dim rs As New ADODB.Recordset
    Dim s As String
    ReDim sTableName(0)
    sTableName(0) = ""
    ReDim sItem(0)
    sItem(0).Code = ""
    ReDim sCode(0)
    sCode(0).Code = ""
    
    '读取字段属性
    With Cw_DataEnvi.DataConnect
        If .State = 0 Then
            .Open
        End If
    End With
    s = "select distinct FieldName as FieldName ,ChName as FieldNameC ,FieldType as DataType ,TableName  as TableFrom,AddMinusItem  from Rs_Items WHERE SID<10 "
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If Not .EOF() Then
            ReDim sFieldWhere(.RecordCount - 1)
        End If
        i = 0
        Do While Not .EOF()
            sFieldWhere(i).NewCByValue Trim(!FieldName & ""), Trim(!FieldNameC & ""), Trim(!TableFrom & ""), !DataType
            If !AddMinusItem Then
                '如果是选入工资表的字段，添加工资表
                i = i + 1
                ReDim Preserve sFieldWhere(UBound(sFieldWhere, 1) + 1)
                sFieldWhere(i).NewCByValue Trim(!FieldName & ""), Trim(!FieldNameC), "PM_PayRoll", !DataType
            End If
            i = i + 1
            .MoveNext
        Loop
        .Close
    End With
    '添加会计年，会计期间，工资类别到工资表,会计年，会计期间到考勤表
    ReDim Preserve sFieldWhere(UBound(sFieldWhere, 1) + 5)
    sFieldWhere(UBound(sFieldWhere, 1)).NewCByValue "KjYear", "会计年", "PM_PayRoll", "1"
    sFieldWhere(UBound(sFieldWhere, 1) - 1).NewCByValue "Period", "会计期间", "PM_PayRoll", "1"
    sFieldWhere(UBound(sFieldWhere, 1) - 2).NewCByValue "SortID", "工资类别", "PM_PayRoll", "1"
    sFieldWhere(UBound(sFieldWhere, 1) - 3).NewCByValue "KjYear", "会计年", "PM_AttendRecord", "1"
    sFieldWhere(UBound(sFieldWhere, 1) - 4).NewCByValue "KjYear", "会计期间", "PM_AttendRecord", "1"
    
    '添加相关项
    s = "Select Distinct CorTable as CorTable,IndexCode as IndexCode ,IndexName as IndexName from Rs_Items " _
       & " where IsNull(CorTable,'')<>'' and SID<10 "
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    s = ""
    With rs
        Do While Not .EOF()
            s = s & " Select " & Trim(!IndexCode & "") & " as TCode ," & Trim(!IndexName & "") & " as TName from " & Trim(!CorTable & "") & " Union "
            .MoveNext
        Loop
    End With
    
    If Trim(s) <> "" Then
            s = UCase(Trim(s))
            s = Mid(s, 1, Len(s) - 5)
    End If
    If Trim(s) <> "" Then
        Set rs = Cw_DataEnvi.DataConnect.Execute(s)
        With rs
            If Not .EOF() Then
                ReDim sCode(.RecordCount - 1)
                i = 0
                Do While Not .EOF()
                    sCode(i).Code = Trim(!TCode & "")
                    sCode(i).Name = Trim(!TName & "")
                    .MoveNext
                    i = i + 1
                Loop
            End If
            .Close
        End With
    End If
    '添加工资类别
    s = "Select SortID as SortID ,SortName as SortName from PM_Sort"
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        Do While Not .EOF()
            ReDim Preserve sCode(UBound(sCode, 1) + 1)
            sCode(UBound(sCode, 1)).Code = Trim(!SortId & "")
            sCode(UBound(sCode, 1)).Name = Trim(!SortName & "")
            .MoveNext
        Loop
    End With
    '添加公式数组
    ReDim sFunction(21)
    sFunction(0).Name = "今天"
    sFunction(0).Code = "GetDate()"
    sFunction(1).Name = "日"
    sFunction(1).Code = "DAY"
    sFunction(2).Name = "月"
    sFunction(2).Code = "MONTH"
    sFunction(3).Name = "年"
    sFunction(3).Code = "YEAR"
    sFunction(4).Name = "TODAY"
    sFunction(4).Code = "GETDATE()"
    '添加操作符
    ReDim sOperate(22)
    sOperate(0).Name = "等于"
    sOperate(0).Code = "="
    sOperate(1).Name = "大于"
    sOperate(1).Code = ">"
    sOperate(2).Name = "小于"
    sOperate(2).Code = "<"
    sOperate(3).Name = "不大于"
    sOperate(3).Code = "<="
    sOperate(4).Name = "不小于"
    sOperate(4).Code = ">="
    sOperate(5).Name = "包含于"
    sOperate(5).Code = "Like"
    sOperate(6).Name = "不等于"
    sOperate(6).Code = "<>"
    
    sOperate(7).Name = "加"
    sOperate(7).Code = "+"
    sOperate(8).Name = "减"
    sOperate(8).Code = "－"
    sOperate(9).Name = "乘以"
    sOperate(9).Code = "*"
    sOperate(10).Name = "除以"
    sOperate(10).Code = "/"
    sOperate(11).Name = "加"
    sOperate(11).Code = "＋"
    sOperate(12).Name = "乘以"
    sOperate(12).Code = "×"
    sOperate(13).Name = "除以"
    sOperate(13).Code = "÷"
    
    sOperate(14).Name = "("
    sOperate(14).Code = "("
    sOperate(15).Name = "（"
    sOperate(15).Code = "("
    sOperate(16).Name = ")"
    sOperate(16).Code = ")"
    sOperate(17).Name = "）"
    sOperate(17).Code = ")"
    
    sOperate(18).Name = "And"
    sOperate(18).Code = "And"
    sOperate(19).Name = "并且"
    sOperate(19).Code = "And"
    sOperate(20).Name = "Or"
    sOperate(20).Code = "Or"
    sOperate(21).Name = "或者"
    sOperate(21).Code = "Or"
    
    sOperate(22).Name = "-"
    sOperate(22).Code = "-"
    Set rs = Nothing
   
    Exit Sub
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
    
End Sub

Private Function Format(sFormula As String) As String '格式化数据,单词之间有一个空格
     Dim i As Integer
     Dim j As Integer
     Dim b As Boolean
     
     If sFieldWhere(0).IsEmpty() Then
        MsgBox "初始化错误!", vbOKOnly + vbCritical
        Exit Function
     End If
     
    '格式化字符串,把操作符两端加空格
     
     sFormula = UCase(" " & sFormula & " ")
     sFormula = Replace(sFormula, "'", " ")
     sFormula = Replace(sFormula, "‘", " ")
     sFormula = Replace(sFormula, "’", " ")
     
     sFormula = Replace(sFormula, "(", " ( ")
     sFormula = Replace(sFormula, ")", " ) ")
     sFormula = Replace(sFormula, "*", " * ")
     sFormula = Replace(sFormula, "+", " + ")
     sFormula = Replace(sFormula, "（", " ( ")
     sFormula = Replace(sFormula, "）", " ) ")
     sFormula = Replace(sFormula, "×", " * ")
     sFormula = Replace(sFormula, "＋", " + ")
     sFormula = Replace(sFormula, "－", " - ")
     sFormula = Replace(sFormula, "÷", " / ")
     sFormula = Replace(sFormula, "/", " / ")
     
     sFormula = Replace(sFormula, "并且", " AND ")
     sFormula = Replace(sFormula, "或者", " OR ")
     
     sFormula = Replace(sFormula, "小于", " < ")
     sFormula = Replace(sFormula, "<", " < ")
     sFormula = Replace(sFormula, "不大于", " <= ")
     sFormula = Replace(sFormula, "<＝", " <= ")
     
     sFormula = Replace(sFormula, "=", " = ")
     sFormula = Replace(sFormula, "＝", " = ")
     sFormula = Replace(sFormula, "等于", " = ")
     
     sFormula = Replace(sFormula, ">", " > ")
     sFormula = Replace(sFormula, "大于", " > ")
     sFormula = Replace(sFormula, ">＝", " >= ")
     sFormula = Replace(sFormula, "不小于", " > ")
     
     sFormula = Replace(sFormula, Chr(13), "")
     sFormula = Replace(sFormula, Chr(10), "")
     
     '应该单独处理日期，因为日期格式中有“-”，同减号相同，没有完成
     '现在只是要求用户录入日期时不空格,比如'2001-01-01',减号空格,比如 ( 10 - 3 )
     
    '去掉多余空格
     
     b = True
     i = 1
     Do While b
        If InStr(1, sFormula, Space(i)) = 0 Then
            b = False
        Else
            i = i + 1
        End If
     Loop
     j = 0
     For j = i To 1 Step -1
        sFormula = Replace(sFormula, "  ", " ")
     Next j
     
     sFormula = Replace(sFormula, "< =", "<=")
     sFormula = Replace(sFormula, "> =", ">=")
     sFormula = Replace(sFormula, "< >", "<>")
     sFormula = Replace(sFormula, "< =", "<=")
     sFormula = Replace(sFormula, "> =", ">=")
     sFormula = Replace(sFormula, "< >", "<>")
     
     Format = sFormula
End Function

Public Function GetTableName(collTable As Collection) '读取查询条件用到的表名
    If collTable Is Nothing Then
        Exit Function
    End If
    Dim i As Integer
    For i = 1 To collTable.Count
        collTable.Remove (i)
    Next
    For i = 0 To UBound(sTableName, 1)
        collTable.Add sTableName(i)
    Next i
End Function

Private Function AddItem(sValue As String, Optional iType As Integer = -1) '添加项目
    '添加项目，以便取得公式内容
    If sItem(0).Code = "" Then
        sItem(0).Code = sValue
        sItem(0).Name = iType
    Else
        ReDim Preserve sItem(UBound(sItem, 1) + 1)
        sItem(UBound(sItem, 1)).Code = sValue
        sItem(UBound(sItem, 1)).Name = iType
    End If
End Function
Private Function GetFormulaSQL() As String '取得计算公式的可执行SQL
    '取得计算公式的可执行SQL，并替换数字型字段名为IsNull(字段名，0)
    Dim i As Integer
    Dim s As String
    If sItem(0).Code = "" Then
        Exit Function
    End If
    s = ""
    For i = 0 To UBound(sItem)
        If sItem(i).Name = DATA_NUMERIC Then
            s = s + " Convert(Numeric(18,2),IsNull(" & Trim(sItem(i).Code) & ",0) )"
        Else
            s = s + " " + Trim(sItem(i).Code) & " "
        End If
    Next i
    GetFormulaSQL = s
End Function

Private Sub Class_Terminate()
    Set PB_CheckStatus = Nothing
End Sub