rpt.cls

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

'//装载用户报表 成功返回True 失败返回False
Public Function Load(ByVal lgRptID As Long, ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim EntryObj As Object
 Dim Sql As String
 '//清除原有数据
 Call hRemove
 Call tRemove
 Call fRemove
 Call lRemove
 '//读取报表数据
 Sql = "select Js_RptID,Js_GroupID,Js_RptName,Js_RptDesc,Js_RptCallName,Js_RptWidth,Js_RptHeight,Js_RightID,Js_FiltrateRightID,Js_ExportRightID,Js_PrintRightID,Js_UserID,Js_Date,Js_Time from Js_Rpt where Js_RptID=" & lgRptID
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaRs.CursorLocation = adUseClient
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  If Not IsNull(DaRs("Js_RptID")) Then Js_RptID = DaRs("Js_RptID")
  If Not IsNull(DaRs("Js_GroupID")) Then Js_GroupID = DaRs("Js_GroupID")
  If Not IsNull(DaRs("Js_RptName")) Then Js_RptName = Trim(DaRs("Js_RptName"))
  If Not IsNull(DaRs("Js_RptDesc")) Then Js_RptDesc = Trim(DaRs("Js_RptDesc"))
  If Not IsNull(DaRs("Js_RptCallName")) Then Js_RptCallName = Trim(DaRs("Js_RptCallName"))
  If Not IsNull(DaRs("Js_RptWidth")) Then Js_RptWidth = DaRs("Js_RptWidth")
  If Not IsNull(DaRs("Js_RptHeight")) Then Js_RptHeight = DaRs("Js_RptHeight")
  If Not IsNull(DaRs("Js_RightID")) Then Js_RightID = DaRs("Js_RightID")
  If Not IsNull(DaRs("Js_FiltrateRightID")) Then Js_FiltrateRightID = DaRs("Js_FiltrateRightID")
  If Not IsNull(DaRs("Js_ExportRightID")) Then Js_ExportRightID = DaRs("Js_ExportRightID")
  If Not IsNull(DaRs("Js_PrintRightID")) Then Js_PrintRightID = DaRs("Js_PrintRightID")
  If Not IsNull(DaRs("Js_UserID")) Then Js_UserID = DaRs("Js_UserID")
  If Not IsNull(DaRs("Js_Date")) Then Js_Date = Trim(DaRs("Js_Date"))
  If Not IsNull(DaRs("Js_Time")) Then Js_Time = Trim(DaRs("Js_Time"))
 Else
  MsgInfo = "错误的报表"
  DaRs.Close
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  Set BaseObj = Nothing
  Load = False
  Exit Function
 End If
 DaRs.Close
 '//读取报表页眉页脚
 Sql = "select Js_HeaderFooterID,Js_RptID,Js_hfTypeID,Js_hfText,Js_hfFontName,Js_hfFontSize,Js_hfFontBold,Js_hfFontItalic,Js_hfFontUnderline,Js_HeaderFooterOrderID from Js_HeaderFooter where Js_RptID=" & lgRptID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   Set EntryObj = New StdRptBase.HeaderFooter
   With EntryObj
    If Not IsNull(DaRs("Js_HeaderFooterID")) Then .Js_HeaderFooterID = DaRs("Js_HeaderFooterID")
    If Not IsNull(DaRs("Js_RptID")) Then .Js_RptID = DaRs("Js_RptID")
    If Not IsNull(DaRs("Js_hfTypeID")) Then .Js_hfTypeID = DaRs("Js_hfTypeID")
    If Not IsNull(DaRs("Js_hfText")) Then .Js_hfText = Trim(DaRs("Js_hfText"))
    If Not IsNull(DaRs("Js_hfFontName")) Then .Js_hfFontName = Trim(DaRs("Js_hfFontName"))
    If Not IsNull(DaRs("Js_hfFontSize")) Then .Js_hfFontSize = DaRs("Js_hfFontSize")
    If Not IsNull(DaRs("Js_hfFontBold")) Then .Js_hfFontBold = DaRs("Js_hfFontBold")
    If Not IsNull(DaRs("Js_hfFontItalic")) Then .Js_hfFontItalic = DaRs("Js_hfFontItalic")
    If Not IsNull(DaRs("Js_hfFontUnderline")) Then .Js_hfFontUnderline = DaRs("Js_hfFontUnderline")
    If Not IsNull(DaRs("Js_HeaderFooterOrderID")) Then .Js_HeaderFooterOrderID = DaRs("Js_HeaderFooterOrderID")
   End With
   hBill.Add EntryObj
   Set EntryObj = Nothing
   DaRs.MoveNext
  Wend
 Else
  MsgInfo = "读取报表错误，报表缺少页眉页脚"
  DaRs.Close
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  Set BaseObj = Nothing
  Load = False
  Exit Function
 End If
 DaRs.Close
 '//读取报表标题
 Sql = "select Js_TitleID,Js_RptID,Js_SRow,Js_ERow,Js_SCol,Js_ECol,Js_Text from Js_Title where Js_RptID=" & lgRptID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   Set EntryObj = New StdRptBase.Title
   With EntryObj
    If Not IsNull(DaRs("Js_TitleID")) Then .Js_TitleID = DaRs("Js_TitleID")
    If Not IsNull(DaRs("Js_RptID")) Then .Js_RptID = DaRs("Js_RptID")
    If Not IsNull(DaRs("Js_SRow")) Then .Js_SRow = DaRs("Js_SRow")
    If Not IsNull(DaRs("Js_ERow")) Then .Js_ERow = DaRs("Js_ERow")
    If Not IsNull(DaRs("Js_SCol")) Then .Js_SCol = DaRs("Js_SCol")
    If Not IsNull(DaRs("Js_ECol")) Then .Js_ECol = DaRs("Js_ECol")
    If Not IsNull(DaRs("Js_Text")) Then .Js_Text = Trim(DaRs("Js_Text"))
   End With
   tBill.Add EntryObj
   Set EntryObj = Nothing
   DaRs.MoveNext
  Wend
 Else
  MsgInfo = "读取报表错误，报表缺少标题"
  DaRs.Close
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  Set BaseObj = Nothing
  Load = False
  Exit Function
 End If
 DaRs.Close
 '//读取报表字段列表
 Sql = "select Js_FieldControlID,Js_RptID,Js_FieldName,Js_FieldDsecID,Js_FieldDsec,Js_FieldLen,Js_FieldWidth,Js_FieldAlign,Js_FieldShowSign,Js_RightID,Js_FieldOrderID,Js_FieldOrderSign from Js_FieldControl where Js_RptID=" & lgRptID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   Set EntryObj = New StdRptBase.FieldControl
   With EntryObj
    If Not IsNull(DaRs("Js_FieldControlID")) Then .Js_FieldControlID = DaRs("Js_FieldControlID")
    If Not IsNull(DaRs("Js_RptID")) Then .Js_RptID = DaRs("Js_RptID")
    If Not IsNull(DaRs("Js_FieldName")) Then .Js_FieldName = Trim(DaRs("Js_FieldName"))
    If Not IsNull(DaRs("Js_FieldDsecID")) Then .Js_FieldDsecID = DaRs("Js_FieldDsecID")
    If Not IsNull(DaRs("Js_FieldLen")) Then .Js_FieldLen = DaRs("Js_FieldLen")
    If Not IsNull(DaRs("Js_FieldWidth")) Then .Js_FieldWidth = DaRs("Js_FieldWidth")
    If Not IsNull(DaRs("Js_FieldAlign")) Then .Js_FieldAlign = DaRs("Js_FieldAlign")
    If Not IsNull(DaRs("Js_FieldShowSign")) Then .Js_FieldShowSign = DaRs("Js_FieldShowSign")
    If Not IsNull(DaRs("Js_RightID")) Then .Js_RightID = DaRs("Js_RightID")
    If Not IsNull(DaRs("Js_FieldOrderID")) Then .Js_FieldOrderID = DaRs("Js_FieldOrderID")
    If Not IsNull(DaRs("Js_FieldOrderSign")) Then .Js_FieldOrderSign = DaRs("Js_FieldOrderSign")
   End With
   fBill.Add EntryObj
   Set EntryObj = Nothing
   DaRs.MoveNext
  Wend
 Else
  MsgInfo = "读取报表错误，报表缺少字段"
  DaRs.Close
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  Set BaseObj = Nothing
  Load = False
  Exit Function
 End If
 DaRs.Close
 '//读取报表搜索条件
 Sql = "select Js_FiltID,Js_RptID,Js_FieldControlID,Js_LinkSign,Js_Desc,Js_OrderID from Js_Filt where Js_RptID=" & lgRptID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   Set EntryObj = New StdRptBase.Filt
   With EntryObj
    If Not IsNull(DaRs("Js_FiltID")) Then .Js_FiltID = DaRs("Js_FiltID")
    If Not IsNull(DaRs("Js_RptID")) Then .Js_RptID = DaRs("Js_RptID")
    If Not IsNull(DaRs("Js_FieldControlID")) Then .Js_FieldControlID = DaRs("Js_FieldControlID")
    If Not IsNull(DaRs("Js_LinkSign")) Then .Js_LinkSign = DaRs("Js_LinkSign")
    If Not IsNull(DaRs("Js_Desc")) Then .Js_Desc = Trim(DaRs("Js_Desc"))
    If Not IsNull(DaRs("Js_OrderID")) Then .Js_OrderID = DaRs("Js_OrderID")
   End With
   lBill.Add EntryObj
   Set EntryObj = Nothing
   DaRs.MoveNext
  Wend
' Else
'  MsgInfo = "读取报表错误，报表缺少搜索字段"
'  DaRs.Close
'  DaCn.Close
'  Set DaRs = Nothing
'  Set DaCn = Nothing
'  Set BaseObj = Nothing
'  Load = False
'  Exit Function
 End If
 DaRs.Close
 
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "装载数据成功"
 Load = True
 Exit Function
ErrHandle:
 MsgInfo = "装载报表，错误：" & Err.Description
 If DaRs.State = adStateOpen Then DaRs.Close
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 Load = False
End Function

'//删除报表
Public Function Del(ByVal lgRptID As Long, ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim DelSign As Long
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim Sql As String
 '//
 If Load(lgRptID, MsgInfo) = False Then
  Del = False
  Exit Function
 End If
 '//
 DelSign = MsgBox("删除[" & Js_RptName & "]？", vbQuestion + vbYesNo + vbDefaultButton2, BaseObj.getMsgInfo)
 If DelSign <> 6 Then
  Set DaCn = Nothing
  Set BaseObj = Nothing
  MsgInfo = "用户取消删除操作"
  Del = False
  Exit Function
 End If
 '//
 Sql = "delete from Js_Rpt where Js_RptID=" & lgRptID
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaCn.Execute Sql
 DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "删除[" & Js_RptName & "]成功"
 Del = True
 Exit Function
ErrHandle:
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaCn = Nothing
 Set BaseObj = Nothing
 MsgInfo = "删除报表，错误：" & Err.Description
 Del = False
End Function

'//统计当前报表数量
Public Function getSum() As Long
 On Error GoTo ErrHandle
 Dim BaseObj As New StdRptBase.StdRptBaseCls
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetValue As Long
 Sql = "select count(*) as RptSum from Js_Rpt"
 DaCn.ConnectionString = BaseObj.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("RptSum")) Then
  RetValue = DaRs("RptSum")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getSum = RetValue
 Exit Function
ErrHandle:
 If DaRs.State = adStateOpen Then DaRs.Close
 If DaCn.State = adStateOpen Then DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Set BaseObj = Nothing
 getSum = 0
End Function