rpt.cls

本系统是一个报表分析查询系统

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

'//本类属性
Public Js_RptID As Long
Public Js_GroupID As Long
Public Js_RptName As String
Public Js_RptDesc As String
Public Js_RptCallName As String
Public Js_RptWidth As Long
Public Js_RptHeight As Long
Public Js_RightID As Long
Public Js_FiltrateRightID As Long
Public Js_ExportRightID As Long
Public Js_PrintRightID As Long
Public Js_UserID As Long
Public Js_Date As String
Public Js_Time As String
'//
Public Js_GroupName As String
Public Js_RightName As String
Public Js_FiltrateRightName As String
Public Js_ExportRightName As String
Public Js_PrintRightName As String

'//本类集合
'/页眉页脚
Public hBill As Collection
'/页标题
Public tBill As Collection
'/页字段
Public fBill As Collection
'页搜索条件
Public lBill As Collection

'//本类方法.初始化集合
Public Sub NewBill()
 Set hBill = New Collection
 Set tBill = New Collection
 Set fBill = New Collection
 Set lBill = New Collection
End Sub

'//清楚集合
Public Sub hRemove()
 Dim iLoop As Integer
 Dim bMax As Integer
 bMax = hBill.Count
 If bMax > 0 Then
  For iLoop = bMax To 1 Step -1
   hBill.Remove iLoop
  Next
 End If
End Sub

Public Sub tRemove()
 Dim iLoop As Integer
 Dim bMax As Integer
 bMax = tBill.Count
 If bMax > 0 Then
  For iLoop = bMax To 1 Step -1
   tBill.Remove iLoop
  Next
 End If
End Sub

Public Sub fRemove()
 Dim iLoop As Integer
 Dim bMax As Integer
 bMax = fBill.Count
 If bMax > 0 Then
  For iLoop = bMax To 1 Step -1
   fBill.Remove iLoop
  Next
 End If
End Sub

Public Sub lRemove()
 Dim iLoop As Integer
 Dim bMax As Integer
 bMax = lBill.Count
 If bMax > 0 Then
  For iLoop = bMax To 1 Step -1
   lBill.Remove iLoop
  Next
 End If
End Sub


'//保存报表数据
'//保存报表 成功返回：True 失败返回False
Public Function Save(ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim Sql As String
 Dim lSql() As String
 Dim iSum As Integer
 Dim iLoop As Integer
 Dim tlMin As Integer
 Dim tlMax As Integer
 '//数据检测
 If hBill.Count = 0 Then
  MsgInfo = "请设计报表页眉页脚"
  Set BaseObj = Nothing
  Set DaCn = Nothing
  Save = False
  Exit Function
 End If
 If tBill.Count = 0 Then
  MsgInfo = "请设计报表标题"
  Set BaseObj = Nothing
  Set DaCn = Nothing
  Save = False
  Exit Function
 End If
 If fBill.Count = 0 Then
  MsgInfo = "请设计报表字段条件"
  Set BaseObj = Nothing
  Set DaCn = Nothing
  Save = False
  Exit Function
 End If
' If lBill.Count = 0 Then
'  MsgInfo = "请设计报表过滤条件"
'  Set BaseObj = Nothing
'  Set DaCn = Nothing
'  Save = False
'  Exit Function
' End If
 
 '//删除原来的数据
 Sql = "delete from Js_Rpt where Js_RptID=" & Js_RptID
 iSum = iSum + 1
 ReDim Preserve lSql(1 To iSum)
 lSql(iSum) = Sql
 '//保存报表主数据
 Sql = "exec NewRpt "
 Sql = Sql & Js_RptID & ","
 Sql = Sql & Js_GroupID & ","
 Sql = Sql & "'" & Js_RptName & "',"
 Sql = Sql & "'" & Js_RptDesc & "',"
 Sql = Sql & "'" & Js_RptCallName & "',"
 Sql = Sql & Js_RptWidth & ","
 Sql = Sql & Js_RptHeight & ","
 Sql = Sql & Js_RightID & ","
 Sql = Sql & Js_FiltrateRightID & ","
 Sql = Sql & Js_ExportRightID & ","
 Sql = Sql & Js_PrintRightID & ","
 Sql = Sql & Js_UserID & ","
 Sql = Sql & "'" & Js_Date & "',"
 Sql = Sql & "'" & Js_Time & "'"
 iSum = iSum + 1
 ReDim Preserve lSql(1 To iSum)
 lSql(iSum) = Sql
 '//保存报表页眉页脚
 For iLoop = 1 To hBill.Count
  With hBill(iLoop)
   Sql = "exec NewHeaderFooter "
   Sql = Sql & .Js_HeaderFooterID & ","
   Sql = Sql & .Js_RptID & ","
   Sql = Sql & .Js_hfTypeID & ","
   Sql = Sql & "'" & .Js_hfText & "',"
   Sql = Sql & "'" & .Js_hfFontName & "',"
   Sql = Sql & .Js_hfFontSize & ","
   Sql = Sql & .Js_hfFontBold & ","
   Sql = Sql & .Js_hfFontItalic & ","
   Sql = Sql & .Js_hfFontUnderline & ","
   Sql = Sql & .Js_HeaderFooterOrderID
  End With
  iSum = iSum + 1
  ReDim Preserve lSql(1 To iSum)
  lSql(iSum) = Sql
 Next
 '//保存报表标题
 For iLoop = 1 To tBill.Count
  With tBill(iLoop)
   Sql = "exec NewTitle "
   Sql = Sql & .Js_TitleID & ","
   Sql = Sql & .Js_RptID & ","
   Sql = Sql & .Js_SRow & ","
   Sql = Sql & .Js_ERow & ","
   Sql = Sql & .Js_SCol & ","
   Sql = Sql & .Js_ECol & ","
   Sql = Sql & "'" & .Js_Text & "'"
  End With
  iSum = iSum + 1
  ReDim Preserve lSql(1 To iSum)
  lSql(iSum) = Sql
 Next
 '//保存报表字段
 For iLoop = 1 To fBill.Count
  With fBill(iLoop)
   Sql = "exec NewFieldControl "
   Sql = Sql & .Js_FieldControlID & ","
   Sql = Sql & .Js_RptID & ","
   Sql = Sql & "'" & .Js_FieldName & "',"
   Sql = Sql & .Js_FieldDsecID & ","
   Sql = Sql & "'" & .Js_FieldDsec & "',"
   Sql = Sql & .Js_FieldLen & ","
   Sql = Sql & .Js_FieldWidth & ","
   Sql = Sql & .Js_FieldAlign & ","
   Sql = Sql & .Js_FieldShowSign & ","
   Sql = Sql & .Js_RightID & ","
   Sql = Sql & .Js_FieldOrderID & ","
   Sql = Sql & .Js_FieldOrderSign
  End With
  iSum = iSum + 1
  ReDim Preserve lSql(1 To iSum)
  lSql(iSum) = Sql
 Next
 '//保存报表过滤条件
 For iLoop = 1 To lBill.Count
  With lBill(iLoop)
   Sql = "exec NewFilt "
   Sql = Sql & .Js_FiltID & ","
   Sql = Sql & .Js_RptID & ","
   Sql = Sql & .Js_FieldControlID & ","
   Sql = Sql & .Js_LinkSign & ","
   Sql = Sql & "'" & .Js_Desc & "',"
   Sql = Sql & .Js_OrderID
  End With
  iSum = iSum + 1
  ReDim Preserve lSql(1 To iSum)
  lSql(iSum) = Sql
 Next
 
 '//保存开始
 tlMin = LBound(lSql)
 tlMax = UBound(lSql)
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaCn.BeginTrans
 For iLoop = tlMin To tlMax
  DaCn.Execute lSql(iLoop)
 Next
 DaCn.CommitTrans
 DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "保存报表成功"
 Save = True
 Exit Function
ErrHandle:
 MsgInfo = "保存报表，错误：" & Err.Description
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 Save = False
End Function