modserver.bas

朋友给的

Attribute VB_Name = "modServer"
'定义全局变量
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public sjstate As String
Public gCnn                    As ADODB.Connection                            '全局唯一数据库连接
Public gCnn1                   As ADODB.Connection                            '电话费数据库连接
Public gUser                   As String                                      '得到程序使用用户名ID
Public gUser_Name              As String                                      '得到程序使用用户名称
Public gEnterPrise_Name        As String                                      '得到程序使用单位名称
Public gstrKfbz                As String                                      '客房标准
Public gstrKfhm                As String                                      '客房号码

Public gUserName               As String                                      '得到数据库用户名称
Public gPassword               As String                                      '得到数据库密码
Public gDatabase               As String                                      '得到数据库名
Public gServer                 As String                                      '得到服务器名
Public QYLX As Long                                                           '企业类型

'以上SQL数据库连接

Public gAccessPath             As String                                      'Access数据库连接路径
Public gAccessName             As String                                      'Access数据库名称
Public gAccessPasswd           As String                                      'Access数据库密码
Public gAccessServer           As String                                      'Access得到服务器名
'以上Access数据库连接

Public gOrcleUserName          As String                                      '得到数据库用户名称
Public gOrclePassword          As String                                      '得到数据库密码
Public gOrcleDatabase          As String                                      '得到数据库名
Public gOrcleServer            As String                                      '得到服务器名
'以上Orcle数据库连接
         '连接数据库的类型
'0:SQL;1:Access;2:orcle:3:其他

Public gDbtype                 As String
Public gSQL                    As String                                      '全局数据库连接字符串
'注册表地址
Public Const gAPP_TYPE         As String = "SYSTEM"                           '应用程序名
Public Const gREG_APP_ROOT     As String = "Software\ZAMIS"                   '登录注册地址
Public gPort                   As String                                      '端口号码
Public gUnitCode               As String
Public gUnit                   As String
'其他参数
Public blnLogout               As Boolean
Public DemoIni                 As New classIniFile
Public gGzyf                   As String
Public gStlx                   As String


Sub Main()
    
    On Error GoTo ErrEnd
    If App.PrevInstance = True Then
        MsgBox "此后台作业系统已被启动！", vbCritical, "系统提示"
        End
    End If
    GetInitPara
    
    If CreateServer = 0 Then
        frmSplash.Show 1
        frmLogin.Show 1
    Else
        frmServer.Show 1
    End If
    Exit Sub
ErrEnd:
    MsgBox Err.Description, vbCritical, "系统提示"

    End
End Sub

Public Sub GetInitPara()
'建立注册表数据
Dim KeyString As String
Dim strPort As String
On Error GoTo err1
    '注册表地址
    KeyString = gREG_APP_ROOT & "\" & gAPP_TYPE
    
    '取数据库类型
    gDbtype = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gDbtype", "")
    
    If gDbtype = "" Then
        gDbtype = "0"
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDbtype", gDbtype
    End If
    '取端口号
    gPort = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gPort", "")
    If gPort = "" Then
        gPort = "1"
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gPort", gPort
    End If
    gPort = Val(gPort)


    If gDbtype = 0 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
        '取服务器
        gServer = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gServer", "")
        If gServer = "" Then
            gServer = "(local)"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gServer", gServer
        End If
        '取数据库
        gDatabase = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gDatabase", "")
        If gDatabase = "" Then
            gDatabase = "Database"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDatabase", gDatabase
        End If
        '取用户
        gUserName = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gUserName", "")
        If gUserName = "" Then
            gUserName = "sa"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gUserName", gUserName
        End If
        '取密码
        gPassword = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gPassword", "")

        
    ElseIf gDbtype = 1 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
        '取服务器
        gAccessServer = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gAccessServer", "")
        If gAccessServer = "" Then
            gAccessServer = "(local)"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessServer", gAccessServer
        End If
        '取数据库
        gAccessName = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gAccessName", "")
        If gAccessName = "" Then
            gAccessName = "Database"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessName", gAccessName
        End If
        '取用户
        gAccessPath = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gAccessPath", "")
        If gAccessPath = "" Then
            gAccessPath = GetAppPath(App.Path)
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessPath", gAccessPath
        End If
        '取密码
        gAccessPasswd = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gAccessPasswd", "")
'        If gAccessPasswd = "" Then
'            gAccessPasswd = ""
'            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessPasswd", gAccessPasswd
'        End If
'        If Len(gAccessPasswd) = 1024 Then gAccessPasswd = ""
        
        
    ElseIf gDbtype = 2 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
'Public gOrcleUserName               As String                                      '得到数据库用户名称
'Public gOrclePassword               As String                                      '得到数据库密码
'Public gOrcleDatabase               As String                                      '得到数据库名
'Public gOrcleServer                 As String                                      '得到服务器名
        '取服务器
        gOrcleServer = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gOrcleServer", "")
        If gOrcleServer = "" Then
            gOrcleServer = "(local)"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleServer", gOrcleServer
        End If
        '取数据库
        gOrcleDatabase = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gOrcleDatabase", "")
        If gOrcleDatabase = "" Then
            gOrcleDatabase = "Database"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleDatabase", gOrcleDatabase
        End If
        '取用户
        gOrcleUserName = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gOrcleUserName", "")
        If gOrcleUserName = "" Then
            gOrcleUserName = "sa"
            SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleUserName", gOrcleUserName
        End If
        '取密码
        gOrclePassword = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gOrclePassword", "")
    
    Else
    End If
    Exit Sub
err1:
    MsgBox Err.Description, vbInformation, "系统提示"
End Sub

Public Function CreateServer() As Long
'建立数据库连接
Dim strsql     As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
On Error GoTo ErrMsg
    Set gCnn = New ADODB.Connection
    
    If gDbtype = 0 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
        strsql = "DRIVER ={SQL SERVER};" _
               & "UID=" & gUserName & ";" _
               & "PWD=" & Trim(gPassword) & ";" _
               & "DATABASE=" & gDatabase & ";" _
               & "SERVER=" & gServer
    
        gCnn.Provider = "SQLOLEDB"
        gCnn.CursorLocation = adUseClient
        gCnn.ConnectionString = strsql
        gCnn.CommandTimeout = 30
        gCnn.Open
        
'        rs.Open "select * from sysunit", gCnn, adOpenStatic, adLockReadOnly
'        If Not rs.EOF Then
'            gUnitCode = rs(0)
'            gUnit = rs(1)
'        End If
'        rs.Close
        
        
    ElseIf gDbtype = 1 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
        gCnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
            gAccessPath + gAccessName & ";Persist Security Info=False"
        gCnn.CommandTimeout = 10
        gCnn.CursorLocation = adUseClient
        gCnn.Open
        
        rs.Open "select * from sysunit", gCnn, adOpenStatic, adLockReadOnly
        If Not rs.EOF Then
            gUnitCode = rs(0)
            gUnit = rs(1)
        End If
        rs.Close
        
        
    ElseIf gDbtype = 2 Then '连接方式 0:SQL;1:Access;2:orcle:3:其他
    Else
    End If
    
    CreateServer = 0
Exit Function

ErrMsg:
    MsgBox Err.Description, vbCritical + vbOKOnly, "系统提示"
    CreateServer = -1
    Set gCnn = Nothing
End Function


Public Function ShowListView(lstName As ListView, rsList As ADODB.Recordset, blnCHK As Boolean, strWidth As String) As String
Dim i, k As Integer
Dim StrA()  As String
On Error GoTo EndLabel
'listview显示数据
    If rsList.State = 0 Then ShowListView = "数据记录集没有打开！请检查后重试！": Exit Function
    
    StrA = Split(strWidth, ",")
    i = UBound(StrA) + 1
'    If i <> rsList.Fields.count Then ShowListView = "列宽度参数不正确！请检查后重试！": Exit Function
    '显示列标题
'    rsList.Sort = rsList.Fields(0).Name & "ASC"
    lstName.ColumnHeaders.Clear
    For k = 0 To rsList.Fields.count - 1
        lstName.ColumnHeaders.Add k + 1, , rsList.Fields(k).name, Val(StrA(k Mod i))
    Next
    '显示数据集内容
    lstName.Sorted = False
    lstName.ListItems.Clear
    If rsList.RecordCount < 1 Then ShowListView = "0": Exit Function
    If Not rsList.BOF Then rsList.MoveFirst
    i = 1
    Do While i <= rsList.RecordCount

        
        lstName.ListItems.Add , i & "_M", rsList.Fields(0).Value & "", 1

        
        For k = 1 To rsList.Fields.count - 1
            Select Case rsList.Fields(k).Type
            Case adChapter, adBSTR, adChar, adWChar, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar:
                lstName.ListItems(i).SubItems(k) = rsList.Fields(k).Value & ""
            Case adDate, adDBDate, 135:  'Format(txtValue, "yyyy-MM-dd")
                lstName.ListItems(i).SubItems(k) = rsList.Fields(k).Value & ""
            Case adEmpty, adCurrency, adDecimal, adVarNumeric, adDouble, adNumeric, adSingle, adBigInt, adInteger, adSmallInt, adTinyInt, adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt:
                lstName.ListItems(i).SubItems(k) = rsList.Fields(k).Value & ""
            Case adBoolean:
                If rsList.Fields(k).Value Then
                    lstName.ListItems(i).SubItems(k) = "是"
                Else
                    lstName.ListItems(i).SubItems(k) = "否"
                End If
            Case Else:
                lstName.ListItems(i).SubItems(k) = rsList.Fields(k).Value & ""
            End Select
        Next
        lstName.ListItems(i).Checked = blnCHK
        rsList.MoveNext
        i = i + 1
    Loop
    ShowListView = "0"
    Exit Function
EndLabel:
    ShowListView = Err.Description
    Err.Clear
End Function

Public Function AddListItem(ComponentName As ComboBox, rsList As ADODB.Recordset) As String
Dim i As Integer
'CBO中显示数据
On Error GoTo ErrAddList
    If rsList.State = 0 Then AddListItem = "记录集未打开！": Exit Function
    If rsList.RecordCount < 1 Then AddListItem = "0": Exit Function
    ComponentName.Clear
    If Not rsList.BOF Then rsList.MoveFirst
    For i = 0 To rsList.RecordCount - 1
        ComponentName.AddItem rsList.Fields(1).Value
        ComponentName.ItemData(ComponentName.NewIndex) = rsList.Fields(0).Value
        rsList.MoveNext
    Next
    AddListItem = "0"
    Exit Function
ErrAddList:
    AddListItem = Err.Description
    Err.Clear
End Function


Public Function AddListItem1(ComponentName As ComboBox, rsList As ADODB.Recordset) As String
Dim i As Integer
'CBO中显示数据
On Error GoTo ErrAddList
    If rsList.State = 0 Then AddListItem1 = "记录集未打开！": Exit Function
    If rsList.RecordCount < 1 Then AddListItem1 = "0": Exit Function
    ComponentName.Clear
    If Not rsList.BOF Then rsList.MoveFirst
    For i = 0 To rsList.RecordCount - 1
        ComponentName.AddItem rsList.Fields(0).Value
'        ComponentName.ItemData(ComponentName.NewIndex) = rsList.Fields(0).value
        rsList.MoveNext
    Next
    AddListItem1 = "0"
    Exit Function
ErrAddList:
    AddListItem1 = Err.Description
    Err.Clear
End Function
'************************
'填充MSFlexGrid的标题头
'************************
Public Sub FillGridHead(ctlGrid As MSFlexGrid, strHead As String, strWidth As String)
    Dim StrA()  As String
    Dim strB()  As String
    Dim intCol  As Integer
    
    StrA = Split(strHead, ",")
    strB = Split(strWidth, ",")

    With ctlGrid
        .Clear
        .Cols = UBound(StrA) + 1
        For intCol = 0 To .Cols - 1
                .ColWidth(intCol) = Val(strB(intCol))
                .TextMatrix(0, intCol) = StrA(intCol)
                .ColAlignment(intCol) = 1
        Next intCol
    End With
End Sub

Function LoselectBm(ByVal strGet As String) As String
    '取-前边的编码
    Dim strSt As String
    Dim i As Long
    
    For i = 1 To Len(strGet)
        strSt = Left(strGet, i)
        If Right(strSt, 1) = "-" Then
            LoselectBm = Left(strSt, Len(strSt) - 1)
            Exit Function
        End If
    Next
    
End Function

Function LoselectMc(ByVal strGet As String) As String
    '取-前边的编码
    Dim strSt As String
    Dim i As Long
    
    For i = 1 To Len(strGet)
        strSt = Right(strGet, i)
        If Left(strSt, 1) = "-" Then
            LoselectMc = Right(strSt, Len(strSt) - 1)
            Exit Function
        End If
    Next
    
End Function