stdrptbasecls.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 = "StdRptBaseCls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'//数据库连接信息
Public Property Let setConStr(ByVal inConStr As String)
 ConStr = inConStr
End Property
Public Property Get getConStr() As String
 getConStr = ConStr
End Property

'//用户内码
Public Property Let setUserID(ByVal inUserID As Long)
 UserID = inUserID
End Property
Public Property Get getUserID() As Long
 getUserID = UserID
End Property

'//基础资料类码
Public Property Let setClassID(ByVal inClassID)
 ClassID = inClassID
End Property
Public Property Get getClassID() As Long
 getClassID = ClassID
End Property

'//提示信息
Public Property Get getMsgInfo() As String
 getMsgInfo = SysInfo.Base.MsgInfo
End Property

'//登录方式
Public Property Get getLoginID() As String
 getLoginID = SysInfo.Base.LoginID
End Property

'//计算MD5字符串
Public Property Get getMd5Pass(ByVal inSrPass As String, ByVal PassLng As Integer) As String
 getMd5Pass = MD5(inSrPass, PassLng)
End Property

'//计算SQL服务器的集合
Public Property Get getSqlList() As Collection
 Dim ServerList As SQLDMO.NameList
 Dim SQLApp As SQLDMO.Application
 Dim iLoop As Long
 Set SQLApp = New SQLDMO.Application
 Set ServerList = SQLApp.ListAvailableSQLServers
 If SqlList.Count > 0 Then
  For iLoop = SqlList.Count To 1 Step -1
   SqlList.Remove iLoop
  Next
 End If
 For iLoop = 1 To ServerList.Count
  SqlList.Add ServerList.Item(iLoop)
 Next
 Set getSqlList = SqlList
End Property

Private Sub Class_Initialize()
 Call DataInit
End Sub

'//类成员方法

'//计算最大内码
Public Function getItemID(ByVal inTableID As Long) As Long
 Dim RetValue As Long
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim TDesc As SysTable
 Sql = "select fInterID,fFieldName,fTableName,fDesc from Js_InterID where finterid=" & inTableID
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  With TDesc
   If Not IsNull(DaRs("fInterID")) Then .FinterID = DaRs("fInterID")
   If Not IsNull(DaRs("fFieldName")) Then .FieldName = Trim(DaRs("fFieldName"))
   If Not IsNull(DaRs("fTableName")) Then .TableName = Trim(DaRs("fTableName"))
   If Not IsNull(DaRs("fDesc")) Then .TableDesc = Trim(DaRs("fDesc"))
  End With
 End If
 DaRs.Close
 If TDesc.FieldName = "" Or TDesc.TableName = "" Then
  RetValue = 0
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  getItemID = RetValue
  Exit Function
 End If
 Sql = "select " & TDesc.FieldName & " from " & TDesc.TableName & "  order by " & TDesc.FieldName & " desc"
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs(0)) Then
  RetValue = DaRs(0) + 1
 Else
  RetValue = 1
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getItemID = RetValue
End Function

'//返回指定的存储过程的内容
Public Function getProcedureText(ByVal ProcedureName As String) As String
 Dim dSqlServer As SQLServer
 Dim dDataBase As Object
 Dim dProcedures As Object
 Dim dProcedure As Object
 Dim RetValue As String
 '//
 Set dSqlServer = New SQLServer
 dSqlServer.Connect SysInfo.Data.Name, SysInfo.Data.User, SysInfo.Data.Pass
 Set dDataBase = dSqlServer.Databases(SysInfo.Data.Data)
 Set dProcedures = dDataBase.StoredProcedures
 Set dProcedure = dProcedures(ProcedureName)
 RetValue = dProcedure.Text
 Set dProcedure = Nothing
 Set dProcedures = Nothing
 Set dDataBase = Nothing
 Set dSqlServer = Nothing
 getProcedureText = RetValue
End Function

'//根据内码计算名称
Public Function getItemName(ByVal inTableID As Long, ByVal inItemID As Long) As String
 Dim RetValue As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim TDesc As SysTable
 Sql = "select fInterID,fFieldName,FFieldText,fTableName,fDesc from Js_InterID where finterid=" & inTableID
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  With TDesc
   If Not IsNull(DaRs("fInterID")) Then .FinterID = DaRs("fInterID")
   If Not IsNull(DaRs("fFieldName")) Then .FieldName = Trim(DaRs("fFieldName"))
   If Not IsNull(DaRs("FFieldText")) Then .FieldText = Trim(DaRs("FFieldText"))
   If Not IsNull(DaRs("fTableName")) Then .TableName = Trim(DaRs("fTableName"))
   If Not IsNull(DaRs("fDesc")) Then .TableDesc = Trim(DaRs("fDesc"))
  End With
 End If
 DaRs.Close
 If TDesc.FieldText = "" Or TDesc.TableName = "" Then
  RetValue = ""
  DaCn.Close
  Set DaRs = Nothing
  Set DaCn = Nothing
  getItemName = RetValue
  Exit Function
 End If
 Sql = "select " & TDesc.FieldText & " from " & TDesc.TableName & " where " & TDesc.FieldName & "=" & inItemID
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs(0)) Then
  RetValue = Trim(DaRs(0))
 Else
  RetValue = ""
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getItemName = RetValue
End Function


'//计算服务器日期及其时间
Public Function GetServerDate(ByVal inType As Integer) As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetVal As String
 Dim RetDate As String
 Dim RetTime As String
 Sql = "select getdate() ServerDate"
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.CursorLocation = adUseClient
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 RetDate = Format(FormatDateTime(DaRs("ServerDate"), vbLongDate), "YYYY-MM-DD")
 RetTime = Format(FormatDateTime(DaRs("ServerDate"), vbLongTime), "HH:MM:SS")
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 Select Case inType
  Case 1
   RetVal = RetDate
  Case 2
   RetVal = RetTime
  Case 3
   RetVal = RetDate & " " & RetTime
 End Select
 GetServerDate = RetVal
End Function

'//计算登录方案的种类
Public Function getLogonClassList() As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetValue As String
 RetValue = ""
 Sql = "select fitemclassid,fitemclassname from Js_LogonPreceptClass order by fitemclassid asc"
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  While Not DaRs.EOF
   If Not IsNull(DaRs("fitemclassid")) And Not IsNull(DaRs("fitemclassname")) Then
    RetValue = RetValue & DaRs("fitemclassid") & "___" & Trim(DaRs("fitemclassname")) & vbCrLf
   End If
   DaRs.MoveNext
  Wend
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getLogonClassList = RetValue
End Function

'//计算权限控制
Public Function getUserRight(ByVal inUserID As Long, ByVal inFunc As Long, ByRef MsgInfo) As Boolean
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim cRight As String
 Dim Rights As String
 Sql = "select Js_RightList from Js_User where Js_UserID=" & inUserID
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.CursorLocation = adUseClient
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("Js_RightList")) Then
  Rights = Trim(DaRs("Js_RightList"))
 Else
  Rights = ""
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 If Trim(Rights) = "" Then
  MsgInfo = "没有操作权限"
  getUserRight = False
  Exit Function
 End If
 If Left(Rights, 1) = "1" Then
  getUserRight = True
  Exit Function
 End If
 cRight = Mid(Rights, inFunc, 1)
 If cRight = "1" Then
  getUserRight = True
  Exit Function
 Else
  MsgInfo = "没有操作权限"
  getUserRight = False
 End If
End Function

'//控制小数位数
Public Function getDigit(ByVal inDigit As Integer) As String
 Dim iLoop As Integer
 Dim RetVal As String
 '//
 If inDigit = 0 Then
  getDigit = "0"
  Exit Function
 End If
 RetVal = "0."
 For iLoop = 1 To inDigit
  RetVal = RetVal & "0"
 Next
 getDigit = RetVal
End Function

'//返回存储过程的默认参数值串
Public Function getDefalut(ByVal inTable As String) As String
 Dim RetVal As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim iPos As Integer
 Dim vValue As Variant
 Sql = "exec sp_helptext '" & inTable & "'"
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF Then
  Do While Not DaRs.EOF
   If Not IsNull(DaRs(0)) Then
    If UCase(Trim(DaRs(0))) = "AS" Then Exit Do
    If Left(Trim(DaRs(0)), 1) = "@" Then
     iPos = InStr(Trim(DaRs(0)), "=")
     If iPos > 0 Then
      vValue = Split(Trim(DaRs(0)), "=")
      RetVal = RetVal & vValue(1) & "|"
     Else
      RetVal = RetVal & "" & "|"
     End If
    End If
   End If
   DaRs.MoveNext
  Loop
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 If Trim(RetVal) <> "" Then
  RetVal = Replace(RetVal, vbCrLf, "")
  RetVal = Left(RetVal, Len(RetVal) - 1)
 End If
 getDefalut = Trim(RetVal)
End Function

'//根据关键字计算关键字值
Public Function getSystemKey(ByVal inKey As String) As String
 Dim DaCn As New ADODB.Connection
 Dim DaRs As New ADODB.Recordset
 Dim Sql As String
 Dim RetVal As String
 Sql = "select js_val from js_system where js_key='" & inKey & "'"
 DaCn.ConnectionString = ConStr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("js_val")) Then
  RetVal = Trim(DaRs("js_val"))
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 getSystemKey = RetVal
End Function

'//系统进程查询
Public Function SystemProcess() As String
 Dim Enum1 As String
 Dim WMI As Object
 Dim objs As Object
 Dim obj As Object
 Set WMI = GetObject("WinMgmts:")
 Set objs = WMI.InstancesOf("Win32_Process")
 For Each obj In objs
   Enum1 = Enum1 + obj.Description + Chr(13) + Chr(10)
 Next
 SystemProcess = Enum1
 Set obj = Nothing
 Set objs = Nothing
 Set WMI = Nothing
End Function

'//系统状态
Public Function SystemStation() As String
 Dim SysInfo As String
 Dim System As Object
 Dim Item As Object
 '//Dim s, System, item
 Dim i As Integer
 Set System = GetObject("winmgmts:").InstancesOf("Win32_ComputerSystem")
 For Each Item In System
  SysInfo = "计算机名称: " & Item.Name & vbCrLf
  SysInfo = SysInfo & "状态: " & Item.Status & vbCrLf
  SysInfo = SysInfo & "类型: " & Item.SystemType & vbCrLf
  SysInfo = SysInfo & "生产厂家: " & Item.Manufacturer & vbCrLf
  SysInfo = SysInfo & "型号: " & Item.Model & vbCrLf
  SysInfo = SysInfo & "内存: ~" & Item.totalPhysicalMemory \ 1024000 & "mb" & vbCrLf
  SysInfo = SysInfo & "域: " & Item.domain & vbCrLf
  SysInfo = SysInfo & "工作组" & Item.Workgroup & vbCrLf
  SysInfo = SysInfo & "当前用户: " & Item.UserName & vbCrLf
  SysInfo = SysInfo & "启动状态" & Item.BootupState & vbCrLf
  SysInfo = SysInfo & "该计算机属于" & Item.PrimaryOwnerName & vbCrLf
  SysInfo = SysInfo & "系统类型" & Item.CreationClassName & vbCrLf
  SysInfo = SysInfo & "计算机类类型" & Item.Description & vbCrLf
  For i = 0 To 1
   SysInfo = SysInfo & Chr(5) & "启动选项" & i & " :" & Item.SystemStartupOptions(i) & vbCrLf
   Next i
  Next
  SystemStation = SysInfo
End Function

'//系统的MAC地址
Public Function getSystemMAC() As String
 Dim objs As Object
 Dim obj As Object
 Dim RetValue As String
 Set objs = GetObject("winmgmts:").ExecQuery( _
      "SELECT MACAddress " & _
      "FROM Win32_NetworkAdapter " & _
      "WHERE " & _
      "((MACAddress Is Not NULL) " & _
      "AND (Manufacturer <> " & _
      "'Microsoft'))")
 For Each obj In objs
  RetValue = obj.MACAddress
  Exit For
 Next obj
 Set obj = Nothing
 Set objs = Nothing
 getSystemMAC = RetValue
End Function

'//系统的IP地址
Public Function getSystemIP() As String
 Dim RetValue As String
 Dim objWMIService As Object
 Dim colItems As Object
 Dim objitem As Object
 Set objWMIService = GetObject("winmgmts:")
 Set colItems = objWMIService.ExecQuery("select IPAddress from Win32_NetworkAdapterConfiguration where IPEnabled='TRUE'")
 For Each objitem In colItems
  RetValue = CStr(objitem.IPAddress(0))
 Next
 getSystemIP = RetValue
End Function