rptfuncbas.bas

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

Attribute VB_Name = "RptFuncBas"
Option Explicit

Public Function RptDataInit(ByRef MsgInfo As String) As Boolean
 
 '//检测是否传入了报表内码
 If RptID = 0 Then
  MsgInfo = "没有指定报表内码"
  RptDataInit = False
  Exit Function
 End If
 
 '//装在报表数据
 Set meRpt = CreateObject("StdRptBase.Rpt")
 Call meRpt.NewBill
 If meRpt.Load(RptID, MsgInfo) = False Then
  RptDataInit = False
  Exit Function
 End If
 
 '//初始化按钮状态
 With Cmd
  .FilCmd = getCmdState(meRpt.Js_FiltrateRightID)
  .ExpCmd = getCmdState(meRpt.Js_ExportRightID)
  .PrtCmd = getCmdState(meRpt.Js_PrintRightID)
 End With
 
 '//初始化报表标题
 Call InitRptTitle

 '//初始化报表布局
 Call InitRptSize

 '//还原标题字符串
 Call InitRptTitleStr

 RptDataInit = True
End Function

'//计算存储过程信息，获取存储过程参数
Public Sub getProInfo(ByVal ProName As String)
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim OrderID As Integer
 Dim pEntry As ProcParam
 Dim iLoop As Integer
 '//
  '//
 If meColCls.Count > 0 Then
  For iLoop = meColCls.Count To 1 Step -1
   meColCls.Remove iLoop
  Next
 End If
 '//
 Sql = "exec sp_help  '" & ProName & "'"
 OrderID = 0
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 While Not DaRs Is Nothing
  OrderID = OrderID + 1
  
  '//填充有效数据
  If OrderID = 2 Then
   If Not DaRs.BOF Then
    While Not DaRs.EOF
     Set pEntry = New ProcParam
     If Not IsNull(DaRs(0)) Then pEntry.pName = Trim(DaRs(0))
     If Not IsNull(DaRs(1)) Then pEntry.pType = Trim(DaRs(1))
     If Not IsNull(DaRs(2)) Then pEntry.pLen = DaRs(2)
     If Not IsNull(DaRs(3)) Then pEntry.pPrec = DaRs(3)
     If Not IsNull(DaRs(4)) Then pEntry.pScale = DaRs(4)
     If Not IsNull(DaRs(5)) Then pEntry.pOrder = DaRs(5)
     If Not IsNull(DaRs(6)) Then pEntry.pColl = Trim(DaRs(6))
     meColCls.Add pEntry
     Set pEntry = Nothing
     DaRs.MoveNext
    Wend
   End If
  End If
  Set DaRs = DaRs.NextRecordset()
  If DaRs.State <> adStateOpen Then Exit Sub
 Wend
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
End Sub


'//计算登录用户是否可以访问过滤按钮
Private Function getCmdState(ByVal inRightID As Long) As Boolean
 Dim RetVal As Boolean
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Sql = "select js_rightid from js_right where js_rightid=" & inRightID & " and js_rightdesc like '%^" & meObj.BaseInfo.getUserID & "^%'"
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  RetVal = True
 Else
  RetVal = False
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getCmdState = RetVal
End Function

'//处理报表标题
Private Sub InitRptTitle()
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim tempVal As String
 If meRpt.hBill.Count > 0 Then
  For iLoop = 1 To meRpt.hBill.Count
   tempVal = meRpt.hBill.Item(iLoop).Js_hfText
   '//处理报表名称
   tempVal = Replace(tempVal, "^RptName", meRpt.Js_RptName, , vbTextCompare)
   '//处理操作用户
   tempVal = Replace(tempVal, "^UserName", meObj.BaseInfo.getItemName(12, meObj.BaseInfo.getUserID), , vbTextCompare)
   '//处理当前日期
   tempVal = Replace(tempVal, "^Date", meObj.BaseInfo.getServerDate(1), , vbTextCompare)
   '//处理当前时间
   tempVal = Replace(tempVal, "^Time", meObj.BaseInfo.getServerDate(2), , vbTextCompare)
   '//处理当前页码
   tempVal = Replace(tempVal, "^Page", "&[页]", , vbTextCompare)
   '//处理总页
   tempVal = Replace(tempVal, "^TotalPage", "&[总页]", , vbTextCompare)
   '//处理分隔号
   tempVal = Replace(tempVal, "!", "|")
   meRpt.hBill.Item(iLoop).Js_hfText = tempVal
  Next
 End If
End Sub

'//处理报表基本参数：计算标题行和标题列
Private Sub InitRptSize()
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Sql = "select (max(js_erow)-min(js_srow)+1) fixRow from Js_Title where Js_RptID=" & meRpt.Js_RptID
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("fixRow")) Then
  Crp.FixRows = DaRs("fixRow")
 End If
 DaRs.Close
 Sql = "select count(*) as MaxCols from Js_FieldControl where js_rptid=" & meRpt.Js_RptID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("MaxCols")) Then
  Crp.MaxCols = DaRs("MaxCols")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
End Sub

'//还原报表标题
Private Sub InitRptTitleStr()
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim aLoop As Integer
 Dim aStr As String
 Dim cRptObj As Object
 Set cRptObj = CreateObject("Cell.Cell50Ctrl.1")
 With cRptObj
  .SetCols Crp.MaxCols + 1, 0
  .SetRows Crp.FixRows + 1, 0
  If meRpt.tBill.Count > 0 Then
   For iLoop = 1 To meRpt.tBill.Count
    .SetCellString meRpt.tBill.Item(iLoop).Js_SCol, meRpt.tBill.Item(iLoop).Js_SRow - 1, 0, meRpt.tBill.Item(iLoop).Js_Text
   Next
  End If
  '//
  For iLoop = 1 To Crp.FixRows
   aStr = ""
   aLoop = aLoop + 1
   ReDim Preserve Crp.TitleStr(1 To aLoop)
   For jLoop = 1 To Crp.MaxCols
    aStr = aStr & .GetCellString2(jLoop, iLoop, 0) & "|"
   Next
   Crp.TitleStr(aLoop) = aStr
  Next
 End With
 Set cRptObj = Nothing
End Sub

'//根据字段类型内码计算字段数据来源码
Public Function getDataSrID(ByVal inFlrID As Long) As Long
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetVal As Long
 Sql = "select Js_FieldSelType from Js_FieldDsec where Js_FieldDsecID=" & inFlrID
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs("Js_FieldSelType") And Not IsNull(DaRs("Js_FieldSelType")) Then
  RetVal = DaRs("Js_FieldSelType")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getDataSrID = RetVal
End Function

'//检测访问权限
Public Function getRightSign(ByVal inRightID As Long) As Boolean
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetVal As Boolean
 RetVal = False
 Sql = "select js_rightid from js_right where js_rightid=" & inRightID & " and js_rightdesc like '%^" & meObj.BaseInfo.getUserID & "^%'"
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("js_rightid")) Then
  RetVal = True
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getRightSign = RetVal
End Function