企业管理

开发平台：
Visual Basic

C_RsPm.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CQuery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Dim iPosSys As Integer '取得一个单词的结束位置
Dim iPosOldSys As Integer '取得一个单词的开始位置
Dim Formula As String   '用户录入的条件或公式
Public FormulaSys As String '查询返回
Public FormulaSQL As String '公式返回
Public FormulaOld As String
Dim sItem() As New CCode '用以返回公式的数组
Dim sFieldWhere() As New CField '字段数组
Dim sFunction() As New CCode '公式数组
Dim sOperate() As New CCode '操作符
Dim sCode() As New CCode '编码
Dim sTableName() As String '用到的表
Dim bChecking As Boolean '公式验证正在进行
Public PB_CheckStatus As ProgressBar '公式验证过程
Private Function ChangeStatus(iValue As Integer, iMax As Integer)
    '显示当前验证的过程
    With PB_CheckStatus
        If .Visible = False Then
            .Visible = True
        End If
        .Max = iMax
        .Value = iValue
    End With
End Function
Private Function GetNextField() As String
  Dim i As Integer
  '取下一个单词
  For i = iPosSys + 1 To Len(Formula)
    If Mid(Formula, i, 1) = " " Then
      GetNextField = Mid(Formula, iPosSys + 1, i - iPosSys - 1)
      iPosOldSys = iPosSys
      iPosSys = i
      Exit For
    End If
  Next i
  
End Function
Private Function IsFunction(s As String) As Integer
    '判断是否函数，如果是，返回s的位置
    Dim i As Integer
    If Trim(s) = "" Then
        IsFunction = -1
        Exit Function
    End If
    For i = 0 To UBound(sFunction, 1)
        If sFunction(i).Include(s) Then
            Exit For
        End If
    Next i
    
    If i > UBound(sFunction, 1) Then
        IsFunction = -1
    Else
        IsFunction = i
    End If
  
End Function
Private Function IsField(s As String) As Integer
  '判断是否是字段名，如果是返回位置，并添加表名
  '同时判断此字段是否在多个表中存在，如果是则要求用户添加表名
  '返回 －1 不是字段 －2 此字段在多个表中存在 >=0 此字段在数组中的位置
    Dim i As Integer
    Dim j As Integer
    j = -1
    
    If Trim(s) = "" Then
        IsField = -1
        Exit Function
    End If
    
    For i = 0 To UBound(sFieldWhere, 1)
        If sFieldWhere(i).Include(s) Then
            If j > 0 Then
                MsgBox "请录入字段:" & s & "的表名"
                IsField = -2
                Exit Function
            Else
                j = i
            End If
        End If
    Next i
    
    If j = -1 Then
        IsField = -1
    Else
        IsField = j
        AddTableName Trim(sFieldWhere(j).TableName)
    End If
  
End Function
Private Function AddTableName(s As String)
    '如果表在数组中不存在则添加表名到数组
    Dim j As Integer
    For j = 0 To UBound(sTableName, 1)
        If UCase(sTableName(j)) = UCase(s) Then
            Exit For
        End If
    Next j
    '没有找到表名，则添加表名
    If j > UBound(sTableName, 1) Then
        If Trim(sTableName(0)) <> "" Then
            ReDim Preserve sTableName(UBound(sTableName, 1) + 1)
            sTableName(UBound(sTableName, 1)) = UCase(s)
        Else
            sTableName(0) = UCase(s)
        End If
    End If
End Function
Private Function IsOperater(s As String) As Boolean
    '判断是否操作符，如果是，返回s的位置
    Dim i As Integer
    If Trim(s) = "" Then
        IsOperater = False
        Exit Function
    End If
    For i = 0 To UBound(sOperate, 1)
        If sOperate(i).Include(s) Then
            IsOperater = True
            Exit For
        End If
    Next i
End Function
Private Function IsCode(s As String) As Integer
     '判断是否是相关项、工资类别、部门等，如果是，返回s的位置
    Dim i As Integer
    If Trim(s) = "" Then
        IsCode = -1
        Exit Function
    End If
    For i = 0 To UBound(sCode, 1)
        If sCode(i).Include(s) Then
            Exit For
        End If
    Next i
    
    If i > UBound(sCode, 1) Then
        IsCode = -1
    Else
        IsCode = i
    End If
End Function
Private Function ReplaceByPos(sExepress As String, sReplace As String, Optional iStart As Integer = 0, Optional iEnd As Integer = 0) As String
    '通过位置替换单词
    '参数：sExepress，要替换的表达式 ；sReplace替换为的表达式；iStart开始位置；iEnd，结束位置
    '把sExepress中从iStart开始到iEnd结束的字符替换为sReplace
    Dim i As Integer
    Dim j As Integer
    Dim sLeft As String
    Dim sRight As String
    
    If iStart > Len(sExepress) Then
        Err.Raise vbObjectError + 100, "ReplaceByPos", "开始位置超出字符长度"
        Exit Function
    End If
    If iStart > iEnd Then
        Err.Raise vbObjectError + 101, "ReplaceByPos", "开始位置超出结束位置"
        Exit Function
    End If
    
    sLeft = Left(sExepress, iStart - 1)
    sRight = Right(sExepress, Len(sExepress) - iEnd + 1)
    ReplaceByPos = sLeft & sReplace & sRight
    iPosSys = Len(sReplace) + iStart
    Formula = ReplaceByPos
End Function
Public Function CheckFormula(sF As String, Optional sUpdateField As String = "") As Boolean
    'sUpdateField="" 查询条件 ，其他 计算公式
    On Error GoTo ErrCtrl
    
    If bChecking = True Then
        Exit Function
    Else
        bChecking = True
    End If
    
    If sF = "" Then
        CheckFormula = True
        Me.FormulaSQL = ""
        Me.FormulaSys = ""
        FormulaOld = ""
        Set Me.PB_CheckStatus = Nothing
        Exit Function
    End If
    
    Dim i As Integer
    Dim j As Integer
    Dim b As Boolean
    Dim s As String
    Dim st As String
    Dim iDataType As Integer
    
    Dim bBeginTrans As Boolean '是否已经开始事务
    
    '初始化表名表和条件表，以及各种变量
    ReDim sTableName(0)
    sTableName(0) = ""
    ReDim sItem(0)
    sItem(0).Code = ""
   
    bBeginTrans = False
    sF = Format(sF)
    FormulaOld = sF
    Formula = sF
    iPosSys = 1
    iPosOldSys = 1
    Me.FormulaSQL = ""
    Me.FormulaSys = ""
    iDataType = DATA_NUMERIC
  '把用户录入转换为数据库格式
  '（中文字段—>数据字段，并且添加数据表名到数组sTableName中，操作符不变，值加单引号）
    
    Do While iPosSys < Len(Formula)
        DoEvents
        s = GetNextField
        i = IsField(s)
        If i = -2 Then
            '如果字段名在多个表中，要求用户添加表名
            bChecking = False
            Exit Function
        End If
        
        If i >= 0 Then '字段
            Formula = ReplaceByPos(Formula, UCase(sFieldWhere(i).GetFullName), iPosOldSys + 1, iPosSys)
            AddItem UCase(sFieldWhere(i).GetFullName), sFieldWhere(i).DataType
            AddTableName sFieldWhere(i).TableName
            iDataType = sFieldWhere(i).DataType
        Else
            If Not IsOperater(s) Then
                b = False
                '单独处理%
                If Mid(s, Len(s), 1) = "%" Then
                    s = Mid(s, 1, Len(s) - 1)
                    b = True
                End If
                
                i = IsCode(s)
                If i >= 0 Then '相关项、部门、工资类别等
                    
                    If b = False Then
                        Formula = ReplaceByPos(Formula, "'" & UCase(sCode(i).Code) & "'", iPosOldSys + 1, iPosSys)
                        AddItem "'" & UCase(sCode(i).Code) & "'", 0
                    Else
                        Formula = ReplaceByPos(Formula, "'" & UCase(sCode(i).Code) & "%'", iPosOldSys + 1, iPosSys)
                        AddItem "'" & UCase(sCode(i).Code) & "%'", 0
                    End If
                Else
                    i = IsFunction(s)
                    If i >= 0 Then ' 公式
                        Formula = ReplaceByPos(Formula, UCase(sFunction(i).Code), iPosOldSys + 1, iPosSys)
                        AddItem UCase(sFunction(i).Code), 0
                    Else
                        If b = False Then
                            If IsNumeric(s) And iDataType = DATA_NUMERIC Then
                                '区分数字的“.”和字段限定符的“.”
                                Formula = ReplaceByPos(Formula, Replace(s, ".", "@"), iPosOldSys + 1, iPosSys)
                                AddItem s
                            Else
                                Formula = ReplaceByPos(Formula, "'" & Replace(s, ".", "@") & "'", iPosOldSys + 1, iPosSys)
                                AddItem "'" & s & "'"
                            End If
                            
                        Else
                            Formula = ReplaceByPos(Formula, "'" & s & "%'", iPosOldSys + 1, iPosSys)
                            AddItem "'" & s & "%'"
                        End If
                    End If
                End If
            Else
                AddItem s
            End If
            
        End If
        '进度
        ChangeStatus iPosSys, Len(Formula)
    Loop
    FormulaSys = Replace(Formula, "@", ".")
    
    '验证公式格式是否正确
    s = Formula
    s = Replace(s, "'", Chr(34))
    s = Replace(s, UCase("like"), "=")
    s = Replace(s, UCase("."), "a") '控件不支持“.”
    s = Replace(s, UCase(" GetDate() "), UCase(" Today "))
    s = Replace(s, UCase("%"), "a") '控件不支持“%”
    s = Replace(s, "@", ".") '替换原来的数字“.”
    s = "c=" & s
    
    Dim SC_Formula As New MSScriptControl.ScriptControl
    SC_Formula.Language = "VBScript"
    SC_Formula.ExecuteStatement (s)
    
    '验证公式字段名称、数据类型是否正确，更新数据库，如果有错误则不正确
    
    If sTableName(0) <> "" Then
        st = ""
        For i = 0 To UBound(sTableName, 1)
            st = st & "," & Trim(sTableName(i))
        Next i
        st = Mid(st, 2, Len(st) - 1)
    End If
    
    If sUpdateField = "" Then '是查询条件
        If sTableName(0) = "" Then
            s = " select top 1 * from PM_PayRoll where " & FormulaSys
        Else
            s = " select top 1 * from " & st & " where " & FormulaSys
        End If
        Cw_DataEnvi.DataConnect.Execute (s)
    Else '是计算公式
        If Trim(st) = "" Then
            st = " PM_PayRoll "
        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 "
    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 "PM_Sort", "工资类别", "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,'')<>''"
    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 "No Fields"
        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, "并且", " 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), "")
     
     '应该单独处理日期，因为日期格式中有“-”，同减号相同，没有完成
     
    '去掉多余空格
     
     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，并替换数字型字段名为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 + " 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

						