cmodule.bas

开发环境：VB6.0 数据库：SQLServer2000 说明：这是一个图库管理系统

Attribute VB_Name = "CModule"
Option Explicit

'提取配置文件内容 Windows Api
Private 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
'写入配置文件内容
Private Declare Function WritePrivateProfileString Lib _
                        "KERNEL32" Alias "WritePrivateProfileStringA" _
                         (ByVal lpAppName As String, _
                          ByVal lpKeyName As String, _
                          ByVal lpString As String, _
                          ByVal lpFileName As String) As Boolean

'启动Windows Api 函数
'必要的声明:
Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9

' Error Code
Public Const ERROR_FILE_NOT_FOUND = 2
Public Const ERROR_PATH_NOT_FOUND = 3
Public Const ERROR_BAD_FORMAT = 11

Public Const SE_ERR_FNF = 2
Public Const SE_ERR_PNF = 3
Public Const SE_ERR_ACCESSDENIED = 5
Public Const SE_ERR_OOM = 8
Public Const SE_ERR_SHARE = 26
Public Const SE_ERR_ASSOCINCOMPLETE = 27
Public Const SE_ERR_DDETIMEOUT = 28
Public Const SE_ERR_DDEFAIL = 29
Public Const SE_ERR_DDEBUSY = 30
Public Const SE_ERR_NOASSOC = 31
Public Const SE_ERR_DLLNOTFOUND = 32

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
'读注册表中信息API
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_BINARY = 3 ' Free form binary
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

'数据库连接
Public objCon As New ADODB.Connection   '数据库连接
Public objIp As String                  '服务器地址
Public objPath As String                '服务器系统安装目录

'************************************************************
'过程名：RegQueryStringValue()
'过程功能：提取注册表信息
'返回：
'************************************************************
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
'retrieve nformation about the key
lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
If lResult = 0 Then
    If lValueType = REG_SZ Then
        'Create a buffer
        strBuf = String(lDataBufSize, Chr$(0))
        'retrieve the key's content
        lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
        If lResult = 0 Then
            'Remove the unnecessary chr$(0)'s
            RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
        End If
    Else
        If lValueType = REG_BINARY Then
            Dim strData As Integer
            'retrieve the key's value
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = strData
            End If
        End If
    End If
End If
End Function

'************************************************************
'过程名：GetString()
'过程功能：读取注册表信息
'返回：
'************************************************************
Function GetString(hKey As Long, strPath As String, strValue As String)
Dim Ret
'Open the key
RegOpenKey hKey, strPath, Ret
'Get the key's content
GetString = RegQueryStringValue(Ret, strValue)
'Close the key
RegCloseKey Ret
End Function
'************************************************************
'过程名：IsConnect()
'过程功能：连接数据库
'返回：成功：true 失败：false
'************************************************************
Public Function IsConnect() As Boolean

    Dim strCon As String
    On Error GoTo Err
    If CModule.objCon.State = 0 Then
        strCon = Get_connection()
        'strCon = "driver={SQL Server};server=202.100.72.251;uid=sa;psd= ;database=tkgl "
        'strCon = "driver={SQL Server};server=202.100.72.251;uid=sa;psd=;database=tkgl "
        CModule.objCon.Open strCon
    End If
    IsConnect = True
    Exit Function
Err:
    IsConnect = False
    Call CloseCon
End Function

'************************************************************
'过程名：   CloseRs(ByVal obj As Object)
'参数：     obj:数据集
'过程功能： 连接数据库
'返回：     无
'************************************************************

Public Sub CloseRs(ByVal obj As ADODB.Recordset)
    If obj.State = adStateOpen Then
        obj.Close
    End If
    Set obj = Nothing
End Sub
'************************************************************
'过程名：   CloseCon()
'参数：     无
'过程功能： 断开数据库
'返回：     无
'************************************************************

Public Sub CloseCon()
    If objCon.State = adStateOpen Then
        objCon.Close
        Set objCon = Nothing
    End If
End Sub

'*************************************************************
'过程名：    Get_connection()
'过程功能：  得到数据库连接字符串
'返回：      数据库连接字符串
'*************************************************************
Public Function Get_connection() As String

Dim strCon As String
Dim Result As String

strCon = String$(200, Chr(32))
Call GetPrivateProfileString("DataBase", "driver", "", strCon, Len(strCon), App.Path + "\config.ini")
strCon = Trim(strCon)
Result = "driver=" & Left(strCon, Len(strCon) - 1) & ";"

strCon = String$(200, Chr(32))
Call GetPrivateProfileString("DataBase", "server", "", strCon, Len(strCon), App.Path + "\config.ini")
strCon = Trim(strCon)
Result = Result & "server=" & Left(strCon, Len(strCon) - 1) & ";"

strCon = String$(200, Chr(32))
Call GetPrivateProfileString("DataBase", "uid", "", strCon, Len(strCon), App.Path + "\config.ini")
strCon = Trim(strCon)
Result = Result & "uid=" & Left(strCon, Len(strCon) - 1) & ";"

strCon = String$(200, Chr(32))
Call GetPrivateProfileString("DataBase", "PWD", "", strCon, Len(strCon), App.Path + "\config.ini")
strCon = Trim(strCon)
Result = Result & "PWD=" & Left(strCon, Len(strCon) - 1) & ";"

strCon = String$(200, Chr(32))
Call GetPrivateProfileString("DataBase", "Database", "", strCon, Len(strCon), App.Path + "\config.ini")
strCon = Trim(strCon)
Result = Result & "Database=" & Left(strCon, Len(strCon) - 1)

Get_connection = Result

End Function

'*************************************************************
'过程名：    GetSys
'参数：      strIp:机器名称 strPath:路径
'过程功能：  得到机器名称或IP地址，得到程序运行路径
'返回：      成功：true 失败：false
'*************************************************************

Public Function GetSys(ByRef strIp As String, ByRef strPath As String) As Boolean
    '数据库连接
    Dim objRs As New ADODB.Recordset
    
    On Error GoTo Err
    If IsConnect() = False Then
        Err.Raise 90
    End If
    objRs.Open "sys", CModule.objCon, , adLockOptimistic, adCmdTable
    If objRs.EOF Then
        Err.Raise 91
    End If
    strIp = Trim(objRs("Ip"))
    strPath = Trim(objRs("Path"))
    If Len(strIp) = 0 Or Len(strPath) = 0 Then
        Err.Raise 91
    End If
    
    Call CloseRs(objRs)