msystools.bas

来自「这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写」· BAS 代码 · 共 368 行

Attribute VB_Name = "mSysTools"
Option Explicit

Public Cn       As New ADODB.Connection
Public Const strSysDBName = "Archives"    '系统数据库名
Public Const strSysLogin = "Archives"     '系统数据库操作员
Public Const strSysPsd = "GXliao"       '密码

Public saPassword       As String       '保存SA密码
Public gSchoolCode      As String

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpString As Any, _
    ByVal lpFileName As String) As Long

Public Function gbGetNewConnect(sSvrName As String, sUsrName As String, sUsrPass As String) As Boolean
'**************************************************
'
'Purpose:
'       create new Connection and save to Cn
'
'Return:
'       if successful return True
'       else return False
'
'**************************************************
    
    Dim sSQL        As String
    
    On Error Resume Next
        
    Cn.Provider = "SQLOLEDB.1"
    sSQL = "Data Source= " & sSvrName & ";"
    sSQL = sSQL & "initial Catalog=;"
    sSQL = sSQL & "User id=" & sUsrName & ";"
    sSQL = sSQL & "password=" & sUsrPass
    
    saPassword = sUsrPass
    
    Screen.MousePointer = vbHourglass
    Cn.Open sSQL
    
    Screen.MousePointer = vbDefault
    
    If Err Then
        Err.Clear
        On Error GoTo ErrGetConnect
        sUsrPass = "GxLiao"
    
        Cn.Provider = "SQLOLEDB.1"
        sSQL = "Data Source= " & sSvrName & ";"
        sSQL = sSQL & "initial Catalog=;"
        sSQL = sSQL & "User id=" & sUsrName & ";"
        sSQL = sSQL & "password=" & sUsrPass
        
        saPassword = sUsrPass
        
        Screen.MousePointer = vbHourglass
        Cn.Open sSQL
        
        Screen.MousePointer = vbDefault
    End If
    
    If Cn Is Nothing Then
        Set Cn = Nothing
        MsgBox "无法连接SQL服务器，请检查服务器上的MSSQLServer服务是否启动。", vbInformation, "提示"
        gbGetNewConnect = False
    Else
        gbGetNewConnect = True
    End If
    Exit Function
ErrGetConnect:
    Err.Clear
    gbGetNewConnect = False
    Screen.MousePointer = vbDefault
'    gshowmsg "连接数据库错误: "
End Function


Public Function SQLGetConnectingUsers(Cn As ADODB.Connection) As Integer
'-  -   -   -   -   -   -   -   -   -   -   -   -   -   -   -
' 得到当前使用本系统的用户数。
'
On Error GoTo ErrSQLGetConnectingUsers

Dim sSQL    As String
Dim RS      As New ADODB.Recordset
Dim Users   As Integer
'
    Screen.MousePointer = vbHourglass
    
    sSQL = "select distinct L.suid,L.name,P.hostname"
    sSQL = sSQL & vbCrLf & " from syslogins L,sysprocesses P"
    sSQL = sSQL & vbCrLf & " where L.suid=P.suid and L.name='QY2000'"
    RS.Open sSQL, Cn
    '
    Users = 0
    Do While Not RS.EOF()
        Users = Users + 1
        RS.MoveNext
    Loop
    RS.Close: Set RS = Nothing
    SQLGetConnectingUsers = Users
    Screen.MousePointer = vbDefault
    Exit Function
ErrSQLGetConnectingUsers:
    SQLGetConnectingUsers = 0
    Screen.MousePointer = vbDefault
    Exit Function
End Function


'Public Function SQLDropDatabase(Cn As ADODB.Connection, sDBName As String) As Boolean
'
'    Dim sSQL As String
'    On Error GoTo errSQLDropDatabase
'
'    Screen.MousePointer = vbHourglass
'
'    If Not SQLExistDatabase(Cn, sDBName) Then
'        SQLDropDatabase = True
'        Screen.MousePointer = vbDefault: Exit Function
'    End If
'
'    Dim sDb As String
'    sDb = SQLGetCurrentDatabaseName(Cn)
'
'    sSQL = "Use master"
'    Cn.Execute sSQL
'
'    sSQL = "DROP DATABASE " & sDBName
'    Cn.Execute sSQL
'
'    If sDBName <> sDb Then  ' 删除的不是当前数据库
'       sSQL = "USE " & sDb
'       Cn.Execute sSQL
'    End If
'
'    SQLDropDatabase = True
'    Screen.MousePointer = vbDefault
'    Exit Function
'
'errSQLDropDatabase:
'If sDBName <> sDb Then
'        sSQL = "USE " & sDb
'        Cn.Execute sSQL
'    End If
'
'    SQLDropDatabase = False
'    Screen.MousePointer = vbDefault
'
'End Function

Public Function SQLGetCurrentDatabaseName(Cn As ADODB.Connection) As String

    Dim sSQL As String
    Dim RS As New ADODB.Recordset
    
    On Error GoTo errSQLGetCurrentDatabaseName
    
    sSQL = "select CurrentDB = DB_NAME()"
    RS.Open sSQL, Cn
    SQLGetCurrentDatabaseName = Trim$(RS!CurrentDb)
    RS.Close
    Exit Function

errSQLGetCurrentDatabaseName:
    SQLGetCurrentDatabaseName = ""

End Function


'Public Function SQLSetOFISPWD(Cn As ADODB.Connection, Optional NewPassword) As Boolean
''-  -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -
''   动态地生成OFIS2的用户口令,并保存到master..OFIS_PASSWORD中。
''
'    Dim PWD     As String
'    Dim NewPwd  As String
'    Dim sSQL    As String
'    Dim sDb     As String
'    '
'    On Error GoTo ErrSQLSetOFISPWD
'    sDb = SQLGetCurrentDatabaseName(Cn)
'    Cn.Execute "USE master"
'    '-  -   -   -   -   -   -   -   -   -   -
'    ' 动态生成password."OFIS + 随机数"
'    '
'    PWD = Left$("OFIS" & (CLng(Now)), 8)
'    If IsMissing(NewPassword) Then
'        NewPwd = PWD
'    Else
'        NewPwd = NewPassword
'        PWD = NewPwd
'    End If
'
'    '-  -   -   -   -   -   -   -   -   -
'    ' 在master数据库上创建OFIS_PWD Table.
'    '
'    sSQL = "if exists (select * from master..sysobjects where id = object_id('master..OFIS_PWD') and sysstat & 0xf = 3)"
'    sSQL = sSQL & vbCrLf & "drop table master..OFIS_PWD"
'    Cn.Execute sSQL
'    '
'    sSQL = "CREATE TABLE master..OFIS_PWD ("
'    sSQL = sSQL & vbCrLf & "ofis_login varchar (20)  NOT NULL,"
'    sSQL = sSQL & vbCrLf & "ofis_password VarBinary(20)  NULL"
'    sSQL = sSQL & vbCrLf & ")"
'    Cn.Execute sSQL
'    sSQL = "grant select on OFIS_PWD to public"
'    Cn.Execute sSQL
'
'    '-  -   -   -   -   -   -   -   -   -   -
'    ' 将口令加密后保存到OFIS_PWD中去。
'    PWD = ConvertHexString((Encrypt(PWD)))
'
'    sSQL = "insert master..OFIS_PWD(ofis_login,ofis_password)"
'    sSQL = sSQL & vbCrLf & "VALUES('OFIS2',null)"
'    Cn.Execute sSQL
'    '
'    sSQL = "update master..OFIS_PWD set ofis_password=" & PWD & " where ofis_login='OFIS2'"
'    If PWD = "" Then
'        sSQL = "update master..OFIS_PWD set ofis_password=NULL where ofis_login='OFIS2'"
'    End If
'    Cn.Execute sSQL
'
'    ' 创建Guest 用户用来读取OFIS_PWD
'    SQLDropLoginID Cn, "OFISGUEST"
'    Cn.Execute "exec sp_addlogin 'OFISGUEST'"
'
'    ' 设置OFIS2的口令
'    If Not SQLSetPWD(Cn, "'OFIS2'", "NULL", NewPwd) Then
'        SQLSetOFISPWD = False
'    Else
'        SQLSetOFISPWD = True
'    End If
'
'    Cn.Execute "USE " & sDb
'    Exit Function
'ErrSQLSetOFISPWD:
'    MsgBox "设置系统内部专用口令时出错。" & vbCrLf & "代号：" & Err & vbCrLf & Error, vbInformation, "错误"
'    On Error Resume Next
'    Cn.Execute "USE " & sDb
'    SQLSetOFISPWD = False
'
'End Function

Public Function SQLExistLoginID(Cn As ADODB.Connection, sLoginID As String) As Boolean

    Dim intNum As Integer
    Dim sSQL As String
    Dim RS As New ADODB.Recordset
    
    On Error Resume Next
    sSQL = "select intNum=Count(*) from master..syslogins where name='" & sLoginID & "'"
    RS.Open sSQL, Cn
    intNum = RS(0)
    If intNum > 0 Then
        SQLExistLoginID = True
    Else
        SQLExistLoginID = False
    End If
End Function

Public Function SQLDropLoginID(Cn As ADODB.Connection, sLoginID As String) As Boolean

    On Error Resume Next
    Dim sSQL As String
    Dim intSUID As Integer
    Dim RS As New ADODB.Recordset
    Dim rsUser As New ADODB.Recordset
    
    Dim sDb As String
    
    If Not SQLExistLoginID(Cn, sLoginID) Then
        SQLDropLoginID = True
        Exit Function
    End If
    On Error GoTo errSQLDropLoginID
    sDb = SQLGetCurrentDatabaseName(Cn)
    
    sSQL = "select suid from master..syslogins where name ='" & sLoginID & "'"
    RS.Open sSQL, Cn
    intSUID = RS(0)
    RS.Close: Set RS = Nothing
    
    sSQL = "select name from master..sysdatabases"
    
    RS.Open sSQL, Cn
    Do Until RS.EOF

       sSQL = "USE " & RS(0)
       sSQL = sSQL & vbCrLf & "if exists(select * from sysalternates where suid=" & intSUID & ")"
       sSQL = sSQL & vbCrLf & "exec sp_dropalias " & sLoginID
       Cn.Execute sSQL
       
       sSQL = "USE " & RS(0)
       sSQL = sSQL & vbCrLf & "if exists(select * from sysusers where suid=" & intSUID & ")"
       sSQL = sSQL & vbCrLf & "exec sp_dropuser " & sLoginID
       Cn.Execute sSQL
        
       RS.MoveNext
    Loop
    RS.Close: Set RS = Nothing
    Cn.Execute "USE master"
    Cn.Execute "EXEC sp_droplogin " & sLoginID
    Cn.Execute "USE " & sDb
    SQLDropLoginID = Not SQLExistLoginID(Cn, sLoginID)
    Exit Function

errSQLDropLoginID:
    On Error Resume Next
    Cn.Execute "USE " & sDb

End Function


Public Sub gShowMsg(Msg As String, Optional iFlag As Byte)
'**************************************************
'
'Purpose:
'       简化弹出Message box
'
'**************************************************
    If IsMissing(iFlag) Or iFlag = 0 Then
        Msg = Msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox Msg & Err.Description, vbInformation, "警告"
    Else
        Msg = Msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox Msg & Err.Description, vbInformation, "提示"
    End If
    
End Sub

Public Function ExistFile(ByVal PathName As String) As Boolean
'
' Check if a file exists
'
Dim sDb         As String
Dim RS          As New ADODB.Recordset
Dim sSQL        As String
Dim sTmp        As String
'
    On Error GoTo NoFile
    
    sTmp = Dir(PathName, 32 + 16 + 2 + 0 + 1 + 4)
    If Len(Trim(sTmp)) = 0 Then
        ExistFile = False
    Else
        ExistFile = True
    End If
    
    Exit Function

NoFile:
    ExistFile = False
    Exit Function

End Function