+

VB开发的ERP系统

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
'******************************************************************
'*    模 块 名 称 :验证用户条件并返回SQL语句
'*    功 能 描 述 :
'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间:2002/01/01
'*    备        注:
'******************************************************************
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 UCase(sCode(i).Name) = UCase(s) Or UCase(sCode(i).Code) = UCase(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
    '如果是空,返回Ture
    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
                If s = "人劳科工资" Then
                    Debug.Print s
                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 "