databas.bas

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

Attribute VB_Name = "DataBas"
Private Type DataCfg
 Name As String
 Data As String
 User As String
 Pass As String
End Type

Public DataParam As DataCfg
Public UserID As String
Public MsgInfo As String
Public obj As Object
Public Const AppTitle = "金软报表管理"
'//
Public Sub Main()
 '//
 If Trim(Format(Date, "YYYY-MM-DD")) > "2008-01-30" Then
  Exit Sub
 End If
 '//
 Dim LoginID As String
 Dim DaCn As New ADODB.Connection
 Dim objLogin As Object
 Dim ConnStr As String
 Set obj = CreateObject("StdRptBase.StdRptBaseCls")
 If obj.getServerDate(1) > "2008-01-30" Then
  Exit Sub
 End If
 LoginID = obj.getLoginID
 Select Case LoginID
  Case "1"
   frmLogin.Show
  Case "2"
   Set objLogin = CreateObject("K3Login.ClsLogin")
   If objLogin.CheckLogin Then
    With DaCn
     .ConnectionTimeout = 5
     .CommandTimeout = 120
     .Open GetConnectString(objLogin.PropsString)
    End With
    ConnStr = GetConnectString(objLogin.PropsString)
    UserID = GetUserID(objLogin.PropsString)
    UserID = K3UserID2UserID(UserID)
    Set objLogin = Nothing
    If Trim(ConnStr) <> "" Then
     '//重新金蝶的数据库参数重写系统配置文件
     Call ReWriteCfg(ConnStr)
    End If
    FrmMain.Show
   End If
  Case Else
   MsgBox "未知的登录方式", vbCritical + vbOKOnly, obj.getMsgInfo
 End Select
End Sub

'//根据k3Login串获取连接串
Public Function GetConnectString(ByVal strLogin As String) As String
 Dim intBegin As Integer
 Dim intEnd As Integer
 intBegin = InStr(strLogin, "{")
 intEnd = InStr(strLogin, "}")
 GetConnectString = Mid(strLogin, intBegin + 1, intEnd - intBegin - 1)
End Function

'//根据k3Login串获取用户
Public Function GetUserID(ByVal strLogin As String) As Long
 Dim intBegin As Integer
 Dim intEnd As Integer
 intBegin = InStr(strLogin, "UserID=")
 intEnd = InStr(Right(strLogin, Len(strLogin) - intBegin), ";")
 GetUserID = Val(Mid(strLogin, intBegin + 7, intEnd - 1))
End Function

'//读取XML文件
Public Function getXmlValue(ByVal XmlFile As String, ByVal AppKey As String, ByRef AppValue As String) As Boolean
 On Error GoTo ErrHandle
 Dim objxml As New DOMDocument
 Dim objNode As IXMLDOMNode
 '//
 Call objxml.Load(XmlFile)
 '//
 Set objNode = objxml.selectSingleNode(AppKey)
 If objNode Is Nothing Then
  AppValue = ""
 Else
  AppValue = objNode.nodeTypedValue
 End If
 '//
 Set objNode = Nothing
 Set objxml = Nothing
 getXmlValue = True
 Exit Function
ErrHandle:
 getXmlValue = False
End Function

'//修改XML文件
Public Function setXmlValue(ByVal XmlFile As String, ByVal AppKey As String, ByVal AppValue As String) As Boolean
 On Error GoTo ErrHandle
 Dim objxml As New DOMDocument
 Dim objNode As IXMLDOMNode
 '//
 Call objxml.Load(XmlFile)
 '//
 Set objNode = objxml.selectSingleNode(AppKey)
 If objNode Is Nothing Then
  Set objNode = Nothing
  Set objxml = Nothing
  setXmlValue = False
  Exit Function
 Else
  objNode.nodeTypedValue = AppValue
  Call objxml.Save(XmlFile)
 End If
 '//
 Set objNode = Nothing
 Set objxml = Nothing
 setXmlValue = True
 Exit Function
ErrHandle:
 setXmlValue = False
End Function

'//重新系统配置文件
Private Sub ReWriteCfg(ByVal DCfg As String)
 Dim XmlFile As String
 Dim iLoop As Integer
 Dim tlMin As Integer
 Dim tlMax As Integer
 Dim vCfg As Variant
 Dim pCfg As Variant
 Dim EObj As Object
 Set EObj = CreateObject("ABCCrypto2.Crypto")
 EObj.License = "131-598-271-072"
 EObj.Password = "FxGang_Soft"
 XmlFile = App.Path & "\System.Xml"
 vCfg = Split(DCfg, ";")
 tlMin = LBound(vCfg)
 tlMax = UBound(vCfg)
 For iLoop = tlMin To tlMax
  pCfg = Split(vCfg(iLoop), "=")
  Select Case pCfg(0)
   Case "User ID"
    DataParam.User = pCfg(1)
   Case "Password"
    DataParam.Pass = pCfg(1)
   Case "Data Source"
    DataParam.Name = pCfg(1)
   Case "Initial Catalog"
    DataParam.Data = pCfg(1)
  End Select
 Next
 With DataParam
  '//MsgBox .Name & "::" & .Data & "::" & .User & "::" & .Pass
  Call setXmlValue(XmlFile, "Rpt/Server/Name", EObj.Encrypt(.Name))
  Call setXmlValue(XmlFile, "Rpt/Server/Data", EObj.Encrypt(.Data))
  Call setXmlValue(XmlFile, "Rpt/Server/User", EObj.Encrypt(.User))
  Call setXmlValue(XmlFile, "Rpt/Server/Pass", EObj.Encrypt(.Pass))
 End With
 Set EObj = Nothing
End Sub

'//用户内码转化,警告：用户名称不能相同
Private Function K3UserID2UserID(ByVal inK3UserID 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 a.js_userid"
 Sql = Sql & " from js_user a"
 Sql = Sql & " inner join t_user b on b.fname=a.js_username"
 Sql = Sql & " where b.fuserid = " & inK3UserID
 DaCn.ConnectionString = obj.getConstr
 DaCn.Open
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 If Not DaRs.EOF And Not IsNull(DaRs("Js_UserID")) Then
  RetVal = DaRs("Js_UserID")
 End If
 DaRs.Close
 DaCn.Close
 Set DaRs = Nothing
 Set DaCn = Nothing
 K3UserID2UserID = RetVal
End Function

'//数据库升级
Public Sub DataUpdat()
 '//开始
 
End Sub