advancedquery.cls

来自「通用书店管理系统」· CLS 代码 · 共 337 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "AdvancedQuery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private gConnection As ADODB.Connection                   '定义一个工作数据库连接

Private arrHeader  As Variant                       '存放表列头
Private strHeaderMerge As String                    '列头合并处理
Private arrDataFields  As Variant                   '存放数据字段
Private arrDataFieldsType As Variant                '存放数据字段的数据类型
Private strFromObjects As String                    '存放表对象
Private strSQLGroupOrder As String                  'SQL中进行分组或排序

Private arrDisplayFields As Variant                 '存放查询交互显示字段
Private arrInnerFields As Variant                   '存放查询数据字段
Private arrInnerFieldsType As Variant               '存放查询数据字段数据类型

Private strConstCondition As String                 '存放常量查询条件

Private strReturnSQL As String                      '存放返回SQL语句
Private rstReturnRecordsets As ADODB.Recordset      '存放返回数据记录集

Private strAdvancedCondition As String               '存放高级查询生成的条件语句
Private arrViewHeader As Variant         '最终要显示的列头
Private arrViewFields As Variant         '最终要显示的字段

Private defPrintInfo As New DefinePrintInfo             '定义打印信息

Private arrGroup As Variant                             '分组
Private arrResizeColWidth As Variant                    '自动列宽缩放
Private arrResizeRowHeight As Variant                   '自动行高缩放
Private arrSort As Variant                              '排序
Private arrSubtotal As Variant                          '汇总

'设置打印信息
Public Property Set PrintInfo(ByVal vNewValue As DefinePrintInfo)
    Set defPrintInfo = vNewValue
End Property

'设置列头合并串
Public Property Let HeaderMerge(ByVal vNewValue As String)
    strHeaderMerge = vNewValue
End Property



'得到一个数据库连接
Public Property Get Connection() As ADODB.Connection
    Set Connection = gConnection
End Property

'设置一个数据库连接
Public Property Set Connection(ByVal vNewValue As ADODB.Connection)
    Set gConnection = vNewValue
End Property

'设置表列头
Public Property Let Header(ByVal vNewValue As Variant)
    arrHeader = vNewValue
End Property

'设置数据字段
Public Property Let DataFields(ByVal vNewValue As Variant)
    arrDataFields = vNewValue
End Property

'设置表对象
Public Property Let FromObjects(ByVal vNewValue As String)
    strFromObjects = vNewValue
End Property

'设置可视用户操作字段
Public Property Let DisplayFields(ByVal vNewValue As Variant)
    arrDisplayFields = vNewValue
End Property

'设置内部用户操作字段
Public Property Let InnerFields(ByVal vNewValue As Variant)
    arrInnerFields = vNewValue
End Property

'设置内部用户字段数据类型
Public Property Let InnerFieldsType(ByVal vNewValue As Variant)
    arrInnerFieldsType = vNewValue
End Property


'设置固定条件
Public Property Let ConstCondition(ByVal vNewValue As String)
    strConstCondition = vNewValue
End Property

'调用高级查询窗体方法
Public Function ShowAdvancedQuery() As Boolean
    Dim frm As New frmAdvancedQuery
    
    With frm
        .arrHeader = arrHeader
        .arrDataFields = arrDataFields
        .arrDataFieldsType = arrDataFieldsType
        
        .arrDisplayFields = arrDisplayFields
        .arrInnerFields = arrInnerFields
        .arrInnerFieldsType = arrInnerFieldsType
        
        .strFromObjects = strFromObjects
        Set .gConnection = gConnection
        
        .Show vbModal
    End With
    
    If frm.blnOK Then
        strAdvancedCondition = frm.AdvancedCondition
        arrViewHeader = frm.arrViewHeader
        arrViewFields = frm.arrViewFields
        Call ShowQueryResult    '显示结果
    End If
    
    Set frm = Nothing
    ShowAdvancedQuery = True
End Function

'调用显示查询结果方法
Private Function ShowQueryResult()
    
    Dim rstWork As New ADODB.Recordset
    
    strReturnSQL = ReturnResultSQL(arrViewHeader, arrViewFields, strFromObjects, strAdvancedCondition, strConstCondition)
    Set rstReturnRecordsets = New ADODB.Recordset
    rstReturnRecordsets.Open strReturnSQL, gConnection, adOpenKeyset, adLockBatchOptimistic
    Set rstWork = rstReturnRecordsets
    
    Dim qr As New QueryResult
    If rstWork.RecordCount > 0 Then _
        qr.InputArray = rstWork.GetRows
    
    
    With qr
        
        .Header = arrViewHeader     '仅显示显示列内容
        .HeaderMerge = ExchangeMerge(strHeaderMerge)
        .DataFieldsType = arrDataFieldsType
        
        .arrGroup = ExchangeCol(arrGroup)
        .arrResizeColWidth = ExchangeCol(arrResizeColWidth)
        .arrResizeRowHeight = ExchangeCol(arrResizeRowHeight)
        .arrSort = ExchangeCol(arrSort)
        .arrSubtotal = ExchangeCol_Two(arrSubtotal)
        
        .ShowQueryResult
        
    End With
    
    Set rstWork = Nothing
End Function

'得到SQL结果
Public Property Get ReturnSQL() As String
    ReturnSQL = strReturnSQL
End Property

'得到结果记录集
Public Property Get ReturnRecordsets() As ADODB.Recordset
    Set ReturnRecordsets = rstReturnRecordsets
End Property

'设置字段数据类型
Public Property Let DataFieldsType(ByVal vNewValue As Variant)
    arrDataFieldsType = vNewValue
End Property

'得到相应的结果语句
Private Function ReturnResultSQL(arrHeader As Variant, arrDataFields As Variant, strFromObjects As String, strCondition As String, strConstCondition As String)
     
     Dim i%, tmp$, tmpHeader$, tmpCondition$
     '给字段名加上别名
     
     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(strCondition) <> "" Then tmpCondition = tmpCondition & " WHERE " & strCondition
     If Trim(tmpCondition) <> "" Then
        If Trim(strConstCondition) <> "" Then
            tmpCondition = tmpCondition & " AND " & strConstCondition
        End If
     Else
        If Trim(strConstCondition) <> "" Then
            tmpCondition = " WHERE " & strConstCondition
        End If
     End If
     tmp = tmp & tmpCondition
     
     '追加分组和排序
     tmp = tmp & " " & strSQLGroupOrder
     
     ReturnResultSQL = tmp
End Function

'预处理属性
Public Property Let Group(ByVal vNewValue As Variant)
    arrGroup = vNewValue
End Property
Public Property Let ResizeColWidth(ByVal vNewValue As Variant)
    arrResizeColWidth = vNewValue
End Property
Public Property Let ResizeRowHeight(ByVal vNewValue As Variant)
    arrResizeRowHeight = vNewValue
End Property
Public Property Let Sort(ByVal vNewValue As Variant)
    arrSort = vNewValue
End Property
Public Property Let Subtotal(ByVal vNewValue As Variant)
    arrSubtotal = vNewValue
End Property

'转换列索引：当用户进行高级查询处理后，可能会引起原列索引的调整
Private Function ExchangeCol(arr As Variant) As Variant
    
    If IsEmpty(arr) Then ExchangeCol = arr: Exit Function
    
    Dim strArr$
    Dim i%, j%
    
    For i = 0 To UBound(arr)
        For j = 0 To UBound(arrViewFields)
            If Trim(arrDataFields(arr(i) - 1)) = Trim(arrViewFields(j)) Then
                strArr = strArr & "," & j + 1: Exit For
            End If
        Next j
    Next i
    If strArr <> "" Then
        strArr = Mid(strArr, 2)
    End If
    arr = Split(strArr, ",")
    
    ExchangeCol = arr
    
End Function

'转换列索引：当用户进行高级查询处理后，可能会引起原列索引的调整(统计)
Private Function ExchangeCol_Two(arr As Variant) As Variant
    
    If IsEmpty(arr) Then ExchangeCol_Two = arr: Exit Function
    
    Dim strArr$
    Dim i%, j%, p%
    
    For p = 0 To UBound(arr, 1)
        strArr = strArr & arr(p, 0) & ","
        For i = 1 To UBound(arr, 2)
            For j = 0 To UBound(arrViewFields)
                If Trim(arr(p, i)) <> "" Then
                    If Trim(arrDataFields(arr(p, i) - 1)) = Trim(arrViewFields(j)) Then
                        strArr = strArr & j + 1: Exit For
                    End If
                End If
            Next j
            strArr = strArr & ","
        Next i
        
        If strArr <> "" Then
            strArr = Left(strArr, Len(strArr) - 1) & ";"
        End If
        
    Next p
    
    If strArr <> "" Then
        strArr = Left(strArr, Len(strArr) - 1)
    End If
    
    
    Dim arr1, arr2, arrSubtotal

    arr1 = Split(strArr, ";")
    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
    
    arr = arrSubtotal
    
    ExchangeCol_Two = arr
    
End Function


'转换列头合并
Private Function ExchangeMerge(strMergeHeader As String) As String
    Dim i%, j%
    If UBound(arrDataFields) <> UBound(arrViewFields) Then
        strMergeHeader = ""
    Else
        For i = 0 To UBound(arrDataFields)
            If Trim(arrDataFields(i)) <> Trim(arrViewFields(i)) Then
                strMergeHeader = ""
                Exit Function
            End If
        Next i
    End If
    
    ExchangeMerge = strMergeHeader
    
End Function
'SQL中进行分组或排序--读取
Public Property Get SQLGroupOrder() As Variant
    SQLGroupOrder = strSQLGroupOrder
End Property

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