tableset.cls

金算盘软件代码

                mvarTailWidth(intCount) = !lngFieldWidth
                mvarTailHeight(intCount) = !lngFieldHeight
                mvarTailLeft(intCount) = !lngFieldLeft
                mvarTailTop(intCount) = !lngFieldTop
                mvarTailAlign(intCount) = IIf(IsNull(!intAlign), 9, !intAlign)
                .MoveNext
           Next
      End If
   End With
   '取保报表标题属性
   strSql = "SELECT * FROM ReportHeadTail WHERE lngReportID=" _
            & mvarReportID & " AND bytFieldType=3"
   Set rstReport = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rstReport
       If Not .EOF Then
           mvarTitleWidth = !lngFieldWidth
           mvarTitleHeight = !lngFieldHeight
           mvarTitleLeft = !lngFieldLeft
           mvarTitleTop = !lngFieldTop
           mvarTitleAlign = IIf(IsNull(!intAlign), 9, !intAlign)
      End If
   End With
   Set rstReport = Nothing
End Sub
'得到SQL语句
Public Function GetSQLPre() As String
    GetSQLPre = GetSelect & Space(1) & mvarFrom
End Function

Private Function GetSelect() As String
Dim intCount As Integer
    intCount = 0
    mstrSelect = ""
    Do While intCount < Columns
       If mstrSelect = "" Then
            mstrSelect = mvarColumnFieldName(intCount) & " As """ & mvarColumnDesc(intCount) & """"
       Else
            mstrSelect = mstrSelect & "," & mvarColumnFieldName(intCount) & " As """ & mvarColumnDesc(intCount) & """"
       End If
       intCount = intCount + 1
    Loop
    Select Case mvarViewID
    Case 134, 135, 136, 137, 322, 324, 327, 328, 329, 330, 331, 332
         GetSelect = "SELECT " & mstrSelect
    Case Else
        GetSelect = "SELECT DISTINCT " & mstrSelect
    End Select
End Function
Private Function GetFrom() As String
    GetFrom = mvarFrom
End Function
'得到条件子句
Private Function GetWhere() As String
    mstrWhere = Filter.GetInitWhere(ReportID, 2)
    If mstrWhere = "" Then
     GetWhere = ""
    Else
     GetWhere = " WHERE " & mstrWhere
    End If
End Function

'保存类到数据库
Public Function SaveTable(Optional blnSaveAs As Boolean = False) As Boolean
Dim blnOK As Boolean
    If blnSaveAs Then
        AddReport blnOK
        mvarReportPrep = 2
    Else
        EditUpdate blnOK
    End If
    SaveTable = blnOK
End Function
'按用户ID重新保存一份标准表
Private Sub AddReport(blnOK As Boolean)
  Dim rstReport As rdoResultset
  Dim strSql As String
  Dim lngReportID As Long
   
    On Error GoTo ErrHandle
    '关闭触发器
    strSql = "Alter Table report Disable All Triggers "
    gclsBase.BaseDB.Execute (strSql)
    lngReportID = GetNewID("Report")
    '复制
    strSql = "Select * from Report"
    Set rstReport = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstReport
       .AddNew
          !lngViewId = mvarViewID
          !bytGroup = mvarGroupNo
          !strReportName = mvarReportName
          !lngOperatorID = gclsBase.OperatorID
          !strDate = "0"
          !bytPrep = 2
          !bytWizard = 5
          !lngParentId = mvarParentID
          !intLevel = mvarLevel + 1
          !strDate = Format(Date, "YYYY-MM-DD")
          !blnIsDetail = 1
          !lngReportID = lngReportID
       .Update
    End With
    
    '打开触发器
    strSql = "Alter Table report Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    Set rstReport = Nothing
    mvarReportID = lngReportID
    CopyReportField lngReportID, blnOK
    If blnOK Then
        EditUpdate blnOK
    End If
    Exit Sub
ErrHandle:
    blnOK = False
End Sub

'复制所有报表字段
Private Sub CopyReportField(ByVal lngReportID As Long, blnOK As Boolean)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim fldReportField As rdoColumn
     
     On Error GoTo ErrHandle
     strSql = "Select * from ReportField Where lngReportId=" & mvarReportID
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
     
     strSql = "Select * from ReportField Where lngReportId=" & lngReportID
     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     
     With rstSource
         Do While Not .EOF
            rstDesc.AddNew
            For Each fldReportField In .rdoColumns
                If UCase(fldReportField.Name) = UCase("lngReportId") Then
                    rstDesc!lngReportID = lngReportID
                Else
                     If UCase(fldReportField.Name) <> UCase("lngReportFieldId") Then
                         rstDesc.rdoColumns(fldReportField.Name).Value = fldReportField.Value
                     End If
                End If
            Next
            rstDesc.Update
            .MoveNext
         Loop
     End With
    blnOK = True
    Exit Sub
ErrHandle:
    blnOK = False
End Sub

'更新用户自定义标准表的修改
Private Sub EditUpdate(blnOK As Boolean)
  Dim strSql As String
  Dim intCount As Integer
  Dim rstTemp As rdoResultset
  
  On Error GoTo ErrHandle
  '更新报表
  strSql = "UPDATE Report Set " & _
              "strReportName='" & mvarReportName & "',bytVersion=" & mvarVersion & _
              ",intGridTop=" & mvarGridTop & ",strDate='" & Format(Date, "YYYY-MM-DD") & _
                "' WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
    
  '初始化报表字段
  strSql = "UPDATE ReportField Set blnIsChoosed=0 " & _
            ",lngReportFieldNO=0  WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
  
  '更新报表字段
  For intCount = 0 To mvarColumns - 1
      strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
                        & "',lngReportFieldNO=" & intCount + 1 & ",lngDisplayWidth=" _
                        & mvarColumnWidth(intCount) & ",blnIsChoosed=1" _
                        & " Where lngReportId= " & mvarReportID _
                        & " And lngViewFieldId=" & mvarColumnID(intCount)
      gclsBase.ExecSQL strSql
  Next intCount
  '删除报表表头表尾栏目
  strSql = "SELECT * FROM ReportHeadTail WHERE lngReportID = " & mvarReportID
  Set rstTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  If rstTemp.EOF = False Then
      strSql = "DELETE * FROM ReportHeadTail WHERE lngReportID = " & mvarReportID
      gclsBase.ExecSQL strSql
  End If
  '关闭触发器
    strSql = "Alter Table ReportHeadTail Disable All Triggers "
    gclsBase.BaseDB.Execute (strSql)
  '添加报表表头表尾栏目
  Set rstTemp = gclsBase.BaseDB.OpenResultset("SELECT * FROM ReportHeadTail", rdOpenDynamic, rdConcurValues)
  With rstTemp
        If .EOF = False Then .MoveLast
        '加报表标题属性
            .AddNew
            !lngReportID = mvarReportID
            !strFieldDesc = mvarReportName
            !bytFieldType = 3
            !lngFieldWidth = mvarTitleWidth
            !lngFieldHeight = mvarTitleHeight
            !lngFieldLeft = mvarTitleLeft
            !lngFieldTop = mvarTitleTop
            !intAlign = mvarTitleAlign
            .Update
            .MoveLast
        '加报表表头栏目
        For intCount = 0 To mvarHeadColumns - 1
            .AddNew
            !lngReportID = mvarReportID
            !strFieldDesc = mvarHeadDesc(intCount)
            !bytFieldType = 1
            !intFieldNO = intCount + 1
            !intFuncIndex = mvarHeadFuncIndex(intCount)
            !lngFieldWidth = mvarHeadWidth(intCount)
            !lngFieldHeight = mvarHeadHeight(intCount)
            !lngFieldLeft = mvarHeadLeft(intCount)
            !lngFieldTop = mvarHeadTop(intCount)
            !intAlign = mvarHeadAlign(intCount)
            .Update
            .MoveLast
        Next intCount
        '加报表表尾栏目
        For intCount = 0 To mvarTailColumns - 1
            .AddNew
            !lngReportID = mvarReportID
            !strFieldDesc = mvarTailDesc(intCount)
            !bytFieldType = 2
            !intFieldNO = intCount + 1
            !intFuncIndex = mvarTailFuncIndex(intCount)
            !lngFieldWidth = mvarTailWidth(intCount)
            !lngFieldHeight = mvarTailHeight(intCount)
            !lngFieldLeft = mvarTailLeft(intCount)
            !lngFieldTop = mvarTailTop(intCount)
            !intAlign = mvarTailAlign(intCount)
            .Update
            .MoveLast
        Next intCount
   End With
   '打开触发器
    strSql = "Alter Table ReportHeadTail Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    Set rstTemp = Nothing
    blnOK = True
    Exit Sub
ErrHandle:
    blnOK = False
    '打开触发器
    strSql = "Alter Table ReportHeadTail Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
End Sub
'显示向导窗口
Public Function ShowWizard(Optional ByVal lngReportID As Long, Optional lngParentId As Long, _
       Optional intParentLevel As Integer, Optional clsWizardFormCond As FormCond, _
       Optional blnIsNew As Boolean = True) As Boolean
   Dim clsFormCond As FormCond
   '准备工作
    If mvarReportID = 0 Then
        GetReportSet lngReportID
    End If
    If mvarParentID = 0 Then
        ParentId = lngParentId
        Level = intParentLevel
    End If
    If clsWizardFormCond Is Nothing Then
        Set clsFormCond = New FormCond
    Else
        Set clsFormCond = clsWizardFormCond
    End If
    '显示向导窗口
    ShowWizard = frmTable.SetTable(Me, clsFormCond)

    If ShowWizard = True Then
       '由向导新生成了一张帐表(还未存到数据库)
       If blnIsNew Then
            Report.ShowListReport 0, 0, Me, clsFormCond
       End If
    End If
End Function

Private Sub Class_Terminate()
    Erase mvarColumnID()
    Erase mvarColumnDesc()
    Erase mvarColumnWidth()
    Erase mvarColumnFieldName()
    Erase mvarColumnFieldType()
    
    Erase mvarHeadDesc()
    Erase mvarHeadFuncIndex()
    Erase mvarHeadWidth()
    Erase mvarHeadHeight()
    Erase mvarHeadLeft()
    Erase mvarHeadTop()
    Erase mvarHeadAlign()
    
    Erase mvarTailDesc()
    Erase mvarTailFuncIndex()
    Erase mvarTailWidth()
    Erase mvarTailHeight()
    Erase mvarTailLeft()
    Erase mvarTailTop()
    Erase mvarTailAlign()
End Sub