query.cls

来自「通用书店管理系统」· CLS 代码 · 共 773 行 · 第 1/2 页

     
     Dim i%, tmp$, tmpHeader$
     '给字段名加上别名
     
     For i = 0 To UBound(arrHeader)
        tmpHeader = Trim(arrHeader(i))
        tmpHeader = "'" & Replace(tmpHeader, "'", "''") & "'"
        tmp = tmp & arrDataFields(i) & " AS " & tmpHeader & ","
     Next i
     If Trim(tmp) <> "" Then tmp = Left(tmp, Len(tmp) - 1)
     
     '追加表对象
     tmp = "SELECT " & tmp & " FROM " & strFromObjects
     '追加固定条件
     If Trim(strConstCondition) <> "" Then tmp = tmp & " WHERE " & strConstCondition
     
     ReturnResultSQL = tmp
End Function

'进行参数输入校验
Private Function Validate() As Boolean
    Dim strDescription$, strSource$
    Dim errID As ErrorCodesNum
    Dim strSQL$
    Dim rstWork As ADODB.Recordset
    Dim i%
    
    On Error GoTo 0     '抛出错误
    
    strSource = "通用查询组件"
    
    If TypeName(arrHeader) = "Empty" Then
        strDescription = "列表头不允许为空！"
        errID = cqHeaderIsNull
        Err.Raise errID, strSource, strDescription
    End If
    
    If TypeName(arrInputArray) <> "Empty" Then Validate = True: Exit Function
    
    If Trim(gConnection.ConnectionString) = "" Then
        strDescription = "数据库连接不允许为空！"
        errID = cqConnectionError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    Err.Number = 0
    gConnection.Execute ("SELECT 'TEST CONNECTION'")
    If Err.Number <> 0 Then
        strDescription = "数据库连接出错！"
        errID = cqConnectionError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If TypeName(arrDataFields) = "Empty" Then
        strDescription = "数据字段不允许为空！"
        errID = cqDataFieldsIsNull
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If Trim(strFromObjects) = "" Then
        strDescription = "表对象为空！"
        errID = cqFromObjectsIsNull
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If UBound(arrHeader) <> UBound(arrDataFields) Then
        strDescription = "表列头和数据字段个数不匹配！"
        errID = cqHeaderNotMatchDataFields
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If TypeName(arrDisplayFields) <> "Empty" And TypeName(arrInnerFields) = "Empty" Then
        strDescription = "查询显示字段和数据字段不匹配！"
        errID = cqDisPlayFieldsNotMatchInnerFields
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If TypeName(arrDisplayFields) = "Empty" And TypeName(arrInnerFields) <> "Empty" Then
        strDescription = "查询显示字段和数据字段不匹配！"
        errID = cqDisPlayFieldsNotMatchInnerFields
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    If TypeName(arrDisplayFields) <> "Empty" And TypeName(arrInnerFields) <> "Empty" Then
        If UBound(arrDisplayFields) <> UBound(arrInnerFields) Then
            strDescription = "查询显示字段和数据字段个数不匹配！"
            errID = cqDisPlayFieldsNotMatchInnerFields
            Err.Raise errID, strSource, strDescription
            Validate = False: Exit Function
        End If
    End If
    
    Err.Number = 0
    gConnection.Execute ("SELECT TOP 1 * FROM " & strFromObjects)
    If Err.Number <> 0 Then
        strDescription = "表对象语法错误！"
        errID = cqFromObjectsSyntaxError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    Err.Number = 0
    strSQL = ReturnResultSQL(arrHeader, arrDataFields, strFromObjects, "")
    strSQL = "SELECT TOP 1 " & Right(strSQL, Len(strSQL) - 7)
    strSQL = strSQL & " " & strSQLGroupOrder
    gConnection.Execute (strSQL)
    If Err.Number <> 0 Then
        strDescription = "数据字段语法错误！"
        errID = cqDataFieldsSyntaxError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    End If
    
    Err.Number = 0
    strSQL = ReturnResultSQL(arrHeader, arrDataFields, strFromObjects, strConstCondition)
    strSQL = "SELECT TOP 1 " & Right(strSQL, Len(strSQL) - 7)
    strSQL = strSQL & " " & strSQLGroupOrder
    Set rstWork = New ADODB.Recordset
    
    rstWork.Open strSQL, gConnection, adOpenKeyset, adLockBatchOptimistic
    If Err.Number <> 0 Then
        strDescription = "固定条件语法错误！"
        errID = cqConstConditionSyntaxError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    Else
        ReDim arrDataFieldsType(rstWork.Fields.Count - 1)
        For i = 0 To rstWork.Fields.Count - 1
            arrDataFieldsType(i) = rstWork.Fields.Item(i).Type
            
        Next i
    End If
    
    Err.Number = 0
    strSQL = ReturnResultSQL(arrDisplayFields, arrInnerFields, strFromObjects, strConstCondition)
    strSQL = "SELECT TOP 1 " & Right(strSQL, Len(strSQL) - 7)
    
    Set rstWork = New ADODB.Recordset
    rstWork.Open strSQL, gConnection, adOpenKeyset, adLockBatchOptimistic
    If Err.Number <> 0 Then
        strDescription = "查询数据字段语法错误！"
        errID = cqInnerFieldsSyntaxError
        Err.Raise errID, strSource, strDescription
        Validate = False: Exit Function
    Else
        ReDim arrInnerFieldsType(rstWork.Fields.Count - 1)
        For i = 0 To rstWork.Fields.Count - 1
            arrInnerFieldsType(i) = rstWork.Fields.Item(i).Type
        Next i
    End If
    
    Set rstWork = Nothing
    
    Validate = True
    
End Function


'得到分组属性
Public Property Get Group() As String
    Dim i&, tmp$
    If TypeName(arrGroup) = "Empty" Then Group = "": Exit Property
    For i = 0 To UBound(arrGroup)
        tmp = tmp & "," & arrGroup(i)
    Next i
    Group = Mid(tmp, 2)
End Property

'设置分组属性
Public Property Let Group(ByVal vNewValue As String)
    arrGroup = Split(vNewValue, ",")
    
    If UBound(arrGroup) = -1 Then Exit Property
    
    Dim strArr$
    Dim i%, j%
    
    
    If Not IsEmpty(arrSort) Then
        For i = 0 To UBound(arrSort)
            For j = 0 To UBound(arrGroup)
                If Val(arrSort(i)) = Val(arrGroup(j)) Then Exit For
            Next j
            If j = UBound(arrGroup) + 1 Then
                strArr = strArr & "," & arrSort(i)
            End If
        Next i
        
        If strArr <> "" Then
            strArr = Mid(strArr, 2)
        End If
        arrSort = Split(strArr, ",")
    End If
    
End Property

'得到自动调整列属性
Public Property Get ResizeColWidth() As String
    Dim i&, tmp$
    If TypeName(arrResizeColWidth) = "Empty" Then ResizeColWidth = "": Exit Property
    For i = 0 To UBound(arrResizeColWidth)
        tmp = tmp & "," & arrResizeColWidth(i)
    Next i
    ResizeColWidth = Mid(tmp, 2)
End Property

'设置自动调整列宽属性
Public Property Let ResizeColWidth(ByVal vNewValue As String)
    arrResizeColWidth = Split(vNewValue, ",")
End Property

'得到调整行高属性
Public Property Get ResizeRowHeight() As String
    Dim i&, tmp$
    If TypeName(arrResizeRowHeight) = "Empty" Then ResizeRowHeight = "": Exit Property
    For i = 0 To UBound(arrResizeRowHeight)
        tmp = tmp & "," & arrResizeRowHeight(i)
    Next i
    ResizeRowHeight = Mid(tmp, 2)
End Property

'设置调整行高属性
Public Property Let ResizeRowHeight(ByVal vNewValue As String)
    arrResizeRowHeight = Split(vNewValue, ",")
End Property

'得到排序属性
Public Property Get Sort() As String
    Dim i&, tmp$
    If TypeName(arrSort) = "Empty" Then Sort = "": Exit Property
    For i = 0 To UBound(arrSort)
        tmp = tmp & "," & arrSort(i)
    Next i
    Sort = Mid(tmp, 2)
End Property

'设置排序属性
Public Property Let Sort(ByVal vNewValue As String)
    Dim arr
    Dim strArr$
    Dim i%, j%
    vNewValue = Replace(vNewValue, " ", "")
    arr = Split(vNewValue, ",")
    If UBound(arr) = -1 Then Exit Property
    
   
    If Not IsEmpty(arrGroup) Then
        For i = 0 To UBound(arr)
            For j = 0 To UBound(arrGroup)
                If Val(arr(i)) = Val(arr(j)) Then Exit For
            Next j
            If j = UBound(arrGroup) + 1 Then
                strArr = strArr & "," & arr(i)
            End If
        Next i
        
        If strArr <> "" Then
            strArr = Mid(strArr, 2)
        End If
        arrSort = Split(strArr, ",")
    Else
        arrSort = arr
    End If
    
End Property

'得到汇总属性
Public Property Get Subtotal() As String
    Dim i&, j&, tmp1$, tmp2$
    If TypeName(arrSubtotal) = "Empty" Then Subtotal = "": Exit Property
    For i = 0 To UBound(arrSubtotal, 1)
        tmp2 = ""
        For j = 0 To UBound(arrSubtotal, 2)
            tmp2 = tmp2 & "," & arrSubtotal(i, j)
        Next j
        tmp2 = Mid(tmp2, 2)
        tmp1 = tmp1 & ";" & tmp1
    Next i
    Subtotal = Mid(tmp1, 2)
End Property

'设置汇总属性
Public Property Let Subtotal(ByVal vNewValue As String)
    On Error GoTo Err
    
    Dim arr1, arr2
    Dim i%, j%
    arr1 = Split(vNewValue, ";")
    If UBound(arr1) > -1 Then
        ReDim arrSubtotal(UBound(arr1), 2)
        For i = 0 To UBound(arr1)
            arr2 = Split(arr1(i), ",")
            For j = 0 To UBound(arr2)
                arrSubtotal(i, j) = arr2(j)
            Next j
        Next i
    End If
    Exit Property
Err:
    On Error GoTo 0
    Err.Raise cqSubtotalError, "通用查询", "汇总参数出错"
    
End Property


Private Sub Class_Initialize()
    
    Dim iniStyle As New Style
        
    On Error GoTo Err
    
    With iniStyle
        .Content = ""
        .FontBold = False
        .FontItalic = False
        .FontSize = 10
        .FontName = "宋体"
        .ForeColor = vbBlack
    End With
   
    With defPrintInfo
         Set .cqPageBrow = iniStyle
         Set .cqFirstTitle = iniStyle
         Set .cqSecondTitle = iniStyle
         Set .cqSayingAboveTable = iniStyle
         Set .cqTable = iniStyle
         Set .cqSayingBelowTable = iniStyle
         Set .cqSign = iniStyle
         Set .cqPageFoot = iniStyle
    End With
    
    Exit Sub
Err:
    MsgBox Err.Description
    
End Sub
'得到列头合并串
Public Property Get HeaderMerge() As String
    HeaderMerge = strHeaderMerge
End Property

'设置列头合并串
Public Property Let HeaderMerge(ByVal vNewValue As String)
    '进行输入串语法判别
    '-----------------
    If Trim(vNewValue) = "" Then Exit Property
    
    Dim arrBef, arrBck
    arrBef = Split(CStr(vNewValue), "{")
    arrBck = Split(CStr(vNewValue), "}")
    If UBound(arrBef) <> UBound(arrBck) Then
        On Error GoTo 0
        Err.Raise cqHeaderMergeError, "通用查询", "列头合并{}号不匹配！"
        Exit Property
    End If
    
    strHeaderMerge = vNewValue
End Property

Private Sub Class_Terminate()
    Set gConnection = Nothing
    Set defPrintInfo = Nothing
    Set rstReturnRecordsets = Nothing
    Set aq = Nothing
    Set gq = Nothing
    Set qr = Nothing
    Set ro = Nothing
End Sub

'SQL中进行分组或排序--读取
Public Property Get SQLGroupOrder() As Variant
    SQLGroupOrder = strSQLGroupOrder
End Property

'SQL中进行分组或排序--设置
Public Property Let SQLGroupOrder(ByVal vNewValue As Variant)
    strSQLGroupOrder = vNewValue
End Property