basmain.bas

主要功能如题

Attribute VB_Name = "basMain"
Public cnnConnection As ADODB.Connection
Public rstCustomers As ADODB.Recordset
Public TrstCustomers As ADODB.Recordset
Public strConnection As String
Public strQry As String
Public blnLoginFlag As Boolean
Public strOperatorID As String      '管理员ID
Public serverName As String         '计算机名
Public serverData As String         '数据库名
Public serverUser As String         '用户名
Public serverPass As String         '密码
Public strPath As String            '应用程序路径
Public Const ERRCAPTION = "错误"
Public Const TIPCAPTION = "提示"
Public Const SYSCAPTION = "轩辕短信计费"
Public Const CODEPASSWORD = "zlbz5361"      '加密/解密轩辕码的密码 ,一经过采用不可改变'操作员帐号

Public Sub Main()

    Dim fNum As Long
    
    On Error GoTo VBError
    
    If App.PrevInstance Then
        End
    End If
    
    If Right(App.Path, 1) <> "\" Then
        strPath = App.Path & "\"
    Else
        strPath = App.Path
    End If
    
    strPath = strPath & "SmmJF.ini"
    
    If Dir(strPath) = "" Then
    
        '没有发现 SmmJF.ini 文件时创建该文件
        fNum = FreeFile
        Open strPath For Output As #fNum
        Print #fNum, "[Sys]"
        Print #fNum, "Server="
        Print #fNum, "Database="
        Print #fNum, "User="
        Print #fNum, "Pass="
        Close #fNum
    End If
        
    
    Do
        serverName = Trim(ReadIni("Sys", "Server", strPath))
        serverData = Trim(ReadIni("Sys", "Database", strPath))
        serverUser = Trim(ReadIni("Sys", "User", strPath))
        serverPass = Trim(ReadIni("Sys", "Pass", strPath))
        serverName = Left(serverName, Len(serverName) - 1)
        serverData = Left(serverData, Len(serverData) - 1)
        serverUser = Left(serverUser, Len(serverUser) - 1)
        serverPass = Left(serverPass, Len(serverPass) - 1)
        
        If serverName = "" Or serverData = "" Or serverUser = "" Then
        
            '数据库设置无效时,显示数据库设置表单
            frmDBset.Show vbModal
        
        End If
        
    Loop While serverName = "" Or serverData = "" Or serverUser = ""
        
    If serverPass <> "" Then
    
        '密码解密
        serverPass = Cipher(serverPass, PASSCODE)
    End If
    
    On Error GoTo ADOError
            
    strConnection = "Provider=SQLOLEDB.1;Password=" & serverPass & ";Persist Security Info=True;User ID=" & serverUser & ";Initial Catalog=" & serverData & ";Data Source=" & serverName
    
    Set cnnConnection = New Connection
    With cnnConnection
        .ConnectionString = strConnection
        .CursorLocation = adUseClient
        .CommandTimeout = 10
        .Open
    End With
        
    Set rstCustomers = New Recordset
    Set TrstCustomers = New Recordset
    
    strQry = "select OperID from JFoperator"
    Set rstCustomers = GetRecordSet(cnnConnection, strQry)
    
    If rstCustomers.RecordCount = 0 Then
    
        '无任何管理员时注册新的管理员
        Load frmSuperEdit
        frmSuperEdit.Tag = "First"
        frmSuperEdit.Show
    Else
    
        '显示登陆表单
        Load frmUserLogin
        frmUserLogin.Tag = "Start"
        frmUserLogin.Show
        
    End If
    
    Exit Sub
VBError:
    DisplayVBError
    Exit Sub
ADOError:
    DisplayADOError cnnConnection
    
End Sub

Public Function GetRecordSet(cnnConnection As ADODB.Connection, sQry As String) As ADODB.Recordset
    
    Dim fun_rstCustomers As ADODB.Recordset
    
    Set fun_rstCustomers = New Recordset
    
    '下面的记录锁类型，因为CursorLocation设为adUseClient
    '实际当打开记录集时，记录锁类型已设为adOpenStatic
    fun_rstCustomers.CursorType = adOpenDynamic
    fun_rstCustomers.LockType = adLockOptimistic
    
    '设置记录集的数据来源为一个SQL串
    fun_rstCustomers.Source = sQry
    
    '设置记录集的连接字符串
    Set fun_rstCustomers.ActiveConnection = cnnConnection
    fun_rstCustomers.Open
    
    Set GetRecordSet = fun_rstCustomers

End Function

'ADO错误处理过程
Public Sub DisplayADOError(cnnConnection As ADODB.Connection)
 
    Dim errLoop As ADODB.Error
    Dim strHelp As String
    
    For Each errLoop In cnnConnection.Errors
        If errLoop.HelpFile = "" Then
            strHelp = "没有帮助信息可用"
        Else
            strHelp = "帮助文件： " & errLoop.HelpFile & "； 帮助内容： " & errLoop.HelpContext
        End If
        MsgBox "ADO 错误 #" & errLoop.Number & vbCrLf & "错误源： " & errLoop.Source & vbCrLf & "SQL 状态： " & errLoop.SQLState & "；本地错误： " & errLoop.NativeError & vbCrLf & vbCrLf & "错误目标： " & errLoop.Description & vbCrLf & vbCrLf & strHelp, vbCritical, "ADO 错误"
    Next
    
End Sub

'VB错误处理过程
Public Sub DisplayVBError()

    If CBool(Err) Then
        MsgBox "VB 错误 #" & Err.Number & vbCrLf & "错误源： " & Err.Source & vbCrLf & vbCrLf & "Description: " & Err.Description, vbCritical, "VB 运行时错误"
        Err.Clear
    End If
    
End Sub

'设置用户短信管理权限
Public Sub SetRight(strUserID As String)

    strQry = "select UserID from userPurview where  banner='SRMsg' and UserID='" & strUserID & "'"
    Set rstCustomers = GetRecordSet(cnnConnection, strQry)
    
    If rstCustomers.RecordCount = 0 Then
        strQry = "insert into userPurview(UserID,banner) values('" & strUserID & "','SRMsg')"
        cnnConnection.Execute strQry
    End If
    
    strQry = "select UserID from userPurview where  banner='ClientMng' and UserID='" & strUserID & "'"
    Set rstCustomers = GetRecordSet(cnnConnection, strQry)
    
    If rstCustomers.RecordCount = 0 Then
        strQry = "insert into userPurview(UserID,banner) values('" & strUserID & "','ClientMng')"
        cnnConnection.Execute strQry
    End If
    
    strQry = "select UserID from userPurview where  banner='MsgLib' and UserID='" & strUserID & "'"
    Set rstCustomers = GetRecordSet(cnnConnection, strQry)
    
    If rstCustomers.RecordCount = 0 Then
        strQry = "insert into userPurview(UserID,banner) values('" & strUserID & "','MsgLib')"
        cnnConnection.Execute strQry
    End If
    
End Sub