query.cls

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

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

Const chrDefaultSplit As String = "|"               '定义默认分隔符

Private gConnection As New 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 arrInputArray As Variant                    '存放输入数组

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

'定义显示模式
Enum ShowModel
    cqJustNormal = 0                                '显示通用查询设置框并屏蔽高级按扭
    cqNormalAdvanced = 1                            '显示通用查询设置框并打开高级按扭
    cqJustAdvanced = 2                              '直接跳到高级设置窗体
    cqJustResult = 3                                '直接跳到结果窗体
    cqJustPrint = 4                                 '直接跳到打印窗体
End Enum

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

'定义错误类型
Enum ErrorCodesNum
    cqErrorFirstID = vbObjectError + 512
    cqHeaderNotMatchDataFields
    cqDisPlayFieldsNotMatchInnerFields
    cqHeaderIsNull
    cqDataFieldsIsNull
    cqFromObjectsIsNull
    cqDisplayFieldsIsNull
    cqInnerFieldsIsNull
    cqInnerFieldsSyntaxError
    cqFromObjectsSyntaxError
    cqDataFieldsSyntaxError
    cqConstConditionSyntaxError
    cqSQLSyntaxError
    cqConnectionError
    cqSubtotalError
    cqHeaderMergeError
End Enum

Dim aq As AdvancedQuery      '定义一个高级查询对象
Dim gq As GeneralQuery       '定义一个常用查询对象
Dim qr As QueryResult        '定义一个查询结果对象
Dim ro As ResultOutput       '定义一个结果输出对象


'得到一个数据库连接
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 Get Header(Optional chrSplit As String = chrDefaultSplit) As String
    Dim i&, tmp$
    If TypeName(arrHeader) = "Empty" Then Header = "": Exit Property
    For i = 0 To UBound(arrHeader)
        tmp = tmp & chrSplit & arrHeader(i)
    Next i
    Header = Mid(tmp, 2)
End Property

'设置表列头
Public Property Let Header(Optional chrSplit As String = chrDefaultSplit, ByVal vNewValue As String)
    If vNewValue <> "" Then
        arrHeader = Split(vNewValue, chrSplit)
    End If
End Property

'得到数据字段
Public Property Get DataFields(Optional chrSplit As String = chrDefaultSplit) As String
    Dim i&, tmp$
    If TypeName(arrDataFields) = "Empty" Then DataFields = "": Exit Property
    For i = 0 To UBound(arrDataFields)
        tmp = tmp & chrSplit & arrDataFields(i)
    Next i
    DataFields = Mid(tmp, 2)
End Property

'设置数据字段
Public Property Let DataFields(Optional chrSplit As String = chrDefaultSplit, ByVal vNewValue As String)
    If Trim(vNewValue) <> "" Then
        arrDataFields = Split(vNewValue, chrSplit)
    End If
End Property

'得到表对象
Public Property Get FromObjects() As String
    FromObjects = strFromObjects
End Property

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

'得到可视用户操作字段
Public Property Get DisplayFields(Optional chrSplit As String = chrDefaultSplit) As String
    Dim i&, tmp$
    If TypeName(arrDisplayFields) = "Empty" Then DisplayFields = "": Exit Property
    For i = 0 To UBound(arrDisplayFields)
        tmp = tmp & chrSplit & arrDisplayFields(i)
    Next i
    DisplayFields = Mid(tmp, 2)
End Property

'设置可视用户操作字段
Public Property Let DisplayFields(Optional chrSplit As String = chrDefaultSplit, ByVal vNewValue As String)
    If Trim(vNewValue) <> "" Then
        arrDisplayFields = Split(vNewValue, chrSplit)
    End If
End Property


'得到内部用户操作字段
Public Property Get InnerFields(Optional chrSplit As String = chrDefaultSplit) As String
    Dim i&, tmp$
    If TypeName(arrInnerFields) = "Empty" Then InnerFields = "": Exit Property
    
    For i = 0 To UBound(arrInnerFields)
        tmp = tmp & chrSplit & arrInnerFields(i)
    Next i
    InnerFields = Mid(tmp, 2)
End Property

'设置内部用户操作字段
Public Property Let InnerFields(Optional chrSplit As String = chrDefaultSplit, ByVal vNewValue As String)
    If Trim(vNewValue) <> "" Then
        arrInnerFields = Split(vNewValue, chrSplit)
    End If
End Property

'得到固定条件
Public Property Get ConstCondition() As String
    ConstCondition = strConstCondition
End Property

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

'得到打印信息
Public Property Get PrintInfo() As DefinePrintInfo
    Set PrintInfo = defPrintInfo
End Property

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

'设置数组
Public Property Let InputArray(ByVal vNewValue As Variant)
    arrInputArray = vNewValue
End Property


'调用显示方法
Public Function Show(ByVal cqModal As ShowModel) As Boolean
    
    '校验
    If Not Validate Then Exit Function
    
    Select Case cqModal
    Case cqJustNormal
        Set gq = Nothing
        Set gq = New GeneralQuery
        Set gq.Connection = gConnection
        
        With gq
            .OnlyShowNormal = True
            
            .Header = arrHeader
            .DataFields = arrDataFields
            .DataFieldsType = arrDataFieldsType
            .FromObjects = strFromObjects
            .SQLGroupOrder = strSQLGroupOrder
            
            .ConstCondition = strConstCondition
            .DisplayFields = arrDisplayFields
            .InnerFields = arrInnerFields
            .InnerFieldsType = arrInnerFieldsType
            .HeaderMerge = strHeaderMerge
            
            .Group = arrGroup
            .Sort = arrSort
            .ResizeColWidth = arrResizeColWidth
            .ResizeRowHeight = arrResizeRowHeight
            .Subtotal = arrSubtotal
            
        Set .PrintInfo = defPrintInfo
        End With
        
        If gq.ShowGeneralQuery(False) Then
            strReturnSQL = gq.ReturnSQL
            Set rstReturnRecordsets = gq.ReturnRecordsets
            Show = True
        Else
            Show = False
        End If
        
    Case cqNormalAdvanced
        Set gq = Nothing
        Set gq = New GeneralQuery
        Set gq.Connection = gConnection
        
        With gq
            .Header = arrHeader
            .DataFields = arrDataFields
            .DataFieldsType = arrDataFieldsType
            .FromObjects = strFromObjects
            .SQLGroupOrder = strSQLGroupOrder
            .ConstCondition = strConstCondition
            .DisplayFields = arrDisplayFields
            .InnerFields = arrInnerFields
            .InnerFieldsType = arrInnerFieldsType
            .HeaderMerge = strHeaderMerge
            
            .Group = arrGroup
            .Sort = arrSort
            .ResizeColWidth = arrResizeColWidth
            .ResizeRowHeight = arrResizeRowHeight
            .Subtotal = arrSubtotal
            
        Set .PrintInfo = defPrintInfo
        End With
        
        If gq.ShowGeneralQuery(True) Then
            strReturnSQL = gq.ReturnSQL
            Set rstReturnRecordsets = gq.ReturnRecordsets
            Show = True
        Else
            Show = False
        End If
        
    Case cqJustAdvanced
        Set aq = Nothing
        Set aq = New AdvancedQuery
        Set aq.Connection = gConnection
        
        With aq
            .Header = arrHeader
            .DataFields = arrDataFields
            .DataFieldsType = arrDataFieldsType
            .FromObjects = strFromObjects
            .SQLGroupOrder = strSQLGroupOrder
            .ConstCondition = strConstCondition
            .DisplayFields = arrDisplayFields
            .InnerFields = arrInnerFields
            .InnerFieldsType = arrInnerFieldsType
            .HeaderMerge = strHeaderMerge
            
            .Group = arrGroup
            .Sort = arrSort
            .ResizeColWidth = arrResizeColWidth
            .ResizeRowHeight = arrResizeRowHeight
            .Subtotal = arrSubtotal
            
        Set .PrintInfo = defPrintInfo
        End With
        
        If aq.ShowAdvancedQuery Then
            strReturnSQL = aq.ReturnSQL
            Set rstReturnRecordsets = aq.ReturnRecordsets
            Show = True
        Else
            Show = False
        End If
    
    Case cqJustResult
         Set qr = Nothing
         Set qr = New QueryResult
         
         Set qr.PrintInfo = defPrintInfo
         
        qr.Header = arrHeader
        qr.arrGroup = arrGroup
        qr.arrResizeColWidth = arrResizeColWidth
        qr.arrResizeRowHeight = arrResizeRowHeight
        qr.arrSort = arrSort
        qr.arrSubtotal = arrSubtotal
        qr.HeaderMerge = strHeaderMerge
            
         If TypeName(arrInputArray) = "Empty" Then
            strReturnSQL = ReturnResultSQL(arrHeader, arrDataFields, strFromObjects, strConstCondition)
            Set rstReturnRecordsets = New ADODB.Recordset
            rstReturnRecordsets.Open strReturnSQL, gConnection, adOpenKeyset, adLockBatchOptimistic
            qr.InputArray = rstReturnRecordsets.GetRows
         Else
            qr.InputArray = arrInputArray
         End If
         
         If qr.ShowQueryResult Then
            Show = True
         Else
            Show = False
         End If
         
    Case cqJustPrint        '直接打印没有必要
    
        Set ro = Nothing
        Set ro = New ResultOutput

        If TypeName(qr) = "Empty" Then
            Show = False
        Else
            ro.FlexGridHwnd = qr.FlexGridHwnd
            Set ro.PrintInfo = defPrintInfo
            ro.showPrint

        End If
        
    End Select
    
End Function

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

'得到结果记录集
Public Property Get ReturnRecordsets() As ADODB.Recordset
    
    Dim rstWork As New Recordset
    If TypeName(rstReturnRecordsets) <> "Nothing" Then _
        Set rstWork = rstReturnRecordsets
    
    Set ReturnRecordsets = rstWork
    Set rstWork = Nothing
    
End Property

'得到结果数组
Public Property Get ReturnArray() As Variant
    Dim rstWork As New Recordset
    
    If TypeName(rstReturnRecordsets) <> "Nothing" Then
        Set rstWork = rstReturnRecordsets
        If rstWork.Recordcount > 0 Then ReturnArray = rstWork.GetRows
    End If
    Set rstWork = Nothing
    
End Property

'得到相应的结果语句
Private Function ReturnResultSQL(arrHeader As Variant, arrDataFields As Variant, strFromObjects As String, strConstCondition As String)
     If IsEmpty(arrHeader) Then ReturnResultSQL = "": Exit Function
     If IsEmpty(arrDataFields) Then ReturnResultSQL = "": Exit Function