rptfuncbas.bas

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

Attribute VB_Name = "RptFuncBas"
Option Explicit

'//计算数据库中的存储过程列表
Public Function getProcList() As String
 Dim RetValue As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Sql = "select name from dbo.sysobjects where OBJECTPROPERTY(id, N'IsProcedure') = 1 order by name asc"
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   If Not IsNull(DaRs("name")) Then RetValue = RetValue & Trim(DaRs("name")) & vbCrLf
   DaRs.MoveNext
  Wend
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getProcList = RetValue
End Function

'//计算当前的行
Public Sub getHfRow()
 Dim iLoop As Integer
 Dim tlMin As Integer
 Dim tlMax As Integer
 Dim valTemp As String
 If meRpt.hOper.Header = True Then
  tlMin = 1
  tlMax = 7
 End If
 If meRpt.hOper.Footer = True Then
  tlMin = 9
  tlMax = 15
 End If
 For iLoop = tlMin To tlMax
  valTemp = frmMain.frmHeadFooterText.GetCellString2(1, iLoop, 0)
  meRpt.hOper.CurRow = iLoop
  If valTemp = "" Then Exit Sub
 Next
End Sub

'//
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

'//
Public Sub getColsInfo(ByVal ProName As String)
 On Error GoTo ErrHandle
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim PobjEntry As RptTitleInfo
 Dim Sql As String
 Dim iLoop As Integer
 Dim StrParam As String
 Dim VParam As Variant
 Dim StrItem As String
' '//判断是否有需要处理的数据
' If meColCls.Count = 0 Then
'  Set PobjEntry = Nothing
'  Set DaRs = Nothing
'  Set DaCn = Nothing
'  Exit Sub
' End If
 StrParam = meObj.BaseInfo.getDefalut(ProName)
 VParam = Split(StrParam, "|")
 Sql = "exec " & ProName
 If meColCls.Count > 0 Then
  For iLoop = 1 To meColCls.Count
   StrItem = VParam(iLoop - 1)
   StrItem = Replace(StrItem, "'", "")
   StrItem = Replace(StrItem, ",", "")
   Select Case meColCls.Item(iLoop).pType
    Case "int", "decimal", "money", "numeric", "real", "smallint", "smallmoney", "tinyint", "varbinary", "bigint", "binary", "bit", "float"
     If StrItem = "" Then
      Sql = Sql & " 0,"
     Else
      Sql = Sql & " " & StrItem & ","
     End If
    Case "nvarchar", "varchar", "char", "datetime", "nchar", "sql_variant"
     Sql = Sql & " '" & StrItem & "',"
    Case Else
   End Select
  Next
  Sql = Left(Sql, Len(Sql) - 1)
 End If
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 '//
 If meRptTitle.Count > 0 Then
  For iLoop = meRptTitle.Count To 1 Step -1
   meRptTitle.Remove iLoop
  Next
 End If
 '//
 For iLoop = 0 To DaRs.Fields.Count - 1
  Set PobjEntry = New RptTitleInfo
  With DaRs.Fields.Item(iLoop)
   PobjEntry.TitleName = .Name
   PobjEntry.TitleTypeID = .Type
  End With
  meRptTitle.Add PobjEntry
  Set PobjEntry = Nothing
 Next
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 If meRptTitle.Count > 0 Then
  frmMain.frmTable.TabEnabled(2) = True
  frmMain.frmTable.TabEnabled(4) = True
 End If
 If meColCls.Count > 0 Then
  frmMain.frmTable.TabEnabled(3) = True
 End If
 Exit Sub
ErrHandle:
 MsgBox "错误：" & Err.Description & Chr(13) & "造成错误的可能原因：" & Chr(13) & "    1、调用的存储过程不满足系统接口要求，修改你的存储过程后再试。", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub

'//
Public Function fID2fName(ByVal fID As Long) As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetValue As String
 Sql = "select js_typename from Js_SysFeildMap where js_typeid=" & fID
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  If Not IsNull(DaRs("js_typename")) Then RetValue = Trim(DaRs("js_typename"))
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 fID2fName = RetValue
End Function

Public Function getCellAlign(ByVal AgName As String) As Long
 '//"左对齐" & vbCrLf & "右对齐" & vbCrLf & "居中对齐" & vbCrLf
 Dim ValLng As Long
 Select Case AgName
  Case "左对齐"
   ValLng = 0
  Case "右对齐"
   ValLng = 1
  Case "居中对齐"
   ValLng = 2
 End Select
 getCellAlign = ValLng
End Function

Public Function getCellAlignCn(ByVal IDName As Long) As String
 Dim ValStr As String
 Select Case IDName
  Case 0
   ValStr = "左对齐"
  Case 1
   ValStr = "右对齐"
  Case 2
   ValStr = "居中对齐"
 End Select
 getCellAlignCn = ValStr
End Function

Public Function getShowSign(ByVal SgName As String) As Long
 '//"显示" & vbCrLf & "隐藏" & vbCrLf
 Dim ValLng As Long
 Select Case SgName
  Case "显示"
   ValLng = 0
  Case "隐藏"
   ValLng = 1
 End Select
 getShowSign = ValLng
End Function

Public Function getShowSignCn(ByVal IDName As Long) As String
 Dim ValStr As String
 Select Case IDName
  Case 0
   ValStr = "显示"
  Case 1
   ValStr = "隐藏"
 End Select
 getShowSignCn = ValStr
End Function

Public Sub EditProInfo(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 meFnd.Count > 0 Then
  For iLoop = meFnd.Count To 1 Step -1
   meFnd.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))
     meFnd.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

'Public Sub EditColsInfo(ByVal ProName As String)
' On Error GoTo ErrHandle
' Dim DaCn As New ADODB.Connection
' Dim DaRs As New ADODB.Recordset
' Dim PobjEntry As RptTitleInfo
' Dim Sql As String
' Dim iLoop As Integer
'
' Sql = "exec " & ProName
' For iLoop = 1 To meFnd.Count
'  Sql = Sql & "  '%',"
' Next
' Sql = Left(Sql, Len(Sql) - 1)
' DaCn.ConnectionString = meObj.BaseInfo.getConStr
' DaCn.Open
' DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
' '//
' If meTitle.Count > 0 Then
'  For iLoop = meTitle.Count To 1 Step -1
'   meTitle.Remove iLoop
'  Next
' End If
' '//
' For iLoop = 0 To DaRs.Fields.Count - 1
'  Set PobjEntry = New RptTitleInfo
'  With DaRs.Fields.Item(iLoop)
'   PobjEntry.TitleName = .Name
'   PobjEntry.TitleTypeID = .Type
'  End With
'  meTitle.Add PobjEntry
'  Set PobjEntry = Nothing
' Next
' DaRs.Close
' DaCn.Close
' Set DaRs = Nothing
' Set DaCn = Nothing
' Exit Sub
'ErrHandle:
' MsgBox "错误：" & Err.Description & Chr(13) & "造成错误的可能原因：" & Chr(13) & "    1、调用的存储过程不满足系统接口要求，修改你的存储过程后再试。", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
'End Sub

Public Sub EditColsInfo(ByVal ProName As String)
 On Error GoTo ErrHandle
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim PobjEntry As RptTitleInfo
 Dim Sql As String
 Dim iLoop As Integer
 Dim StrParam As String
 Dim VParam As Variant
 Dim StrItem As String
' '//判断是否有需要处理的数据
' If meColCls.Count = 0 Then
'  Set PobjEntry = Nothing
'  Set DaRs = Nothing
'  Set DaCn = Nothing
'  Exit Sub
' End If
 StrParam = meObj.BaseInfo.getDefalut(ProName)
 VParam = Split(StrParam, "|")
 Sql = "exec " & ProName
 If meFnd.Count > 0 Then
  For iLoop = 1 To meFnd.Count
   StrItem = VParam(iLoop - 1)
   StrItem = Replace(StrItem, "'", "")
   StrItem = Replace(StrItem, ",", "")
   Select Case meFnd.Item(iLoop).pType
    Case "int", "decimal", "money", "numeric", "real", "smallint", "smallmoney", "tinyint", "varbinary", "bigint", "binary", "bit", "float"
     If StrItem = "" Then
      Sql = Sql & " 0,"
     Else
      Sql = Sql & " " & StrItem & ","
     End If
    Case "nvarchar", "varchar", "char", "datetime", "nchar", "sql_variant"
     Sql = Sql & " '" & StrItem & "',"
    Case Else
   End Select
  Next
  Sql = Left(Sql, Len(Sql) - 1)
 End If
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 '//
 If meTitle.Count > 0 Then
  For iLoop = meTitle.Count To 1 Step -1
   meTitle.Remove iLoop
  Next
 End If
 '//
 For iLoop = 0 To DaRs.Fields.Count - 1
  Set PobjEntry = New RptTitleInfo
  With DaRs.Fields.Item(iLoop)
   PobjEntry.TitleName = .Name
   PobjEntry.TitleTypeID = .Type
  End With
  meTitle.Add PobjEntry
  Set PobjEntry = Nothing
 Next
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 If meTitle.Count > 0 Then
  frmMain.frmTable.TabEnabled(2) = True
  frmMain.frmTable.TabEnabled(4) = True
 End If
 If meFnd.Count > 0 Then
  frmMain.frmTable.TabEnabled(3) = True
 End If
 Exit Sub
ErrHandle:
 MsgBox "错误：" & Err.Description & Chr(13) & "造成错误的可能原因：" & Chr(13) & "    1、调用的存储过程不满足系统接口要求，修改你的存储过程后再试。", vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub