Private   Const   ODBC_ADD_DSN   =   1
Private   Const   ODBC_CONFIG_DSN   =   2
Private   Const   ODBC_REMOVE_DSN   =   3
Private   Const   ODBC_ADD_SYS_DSN   =   4
Private   Const   ODBC_REMOVE_SYS_DSN   =   6
Private   Const   vbAPINull   As   Long   =   0&

Private   Const   SQL_SUCCESS   As   Long   =   0
Private   Const   SQL_ERROR   As   Long   =   -1
Private   Const   SQL_FETCH_NEXT   As   Long   =   1

Private   Declare   Function   SQLConfigDataSource   Lib   "ODBCCP32.DLL"   (ByVal   hwndParent   As   Long,   ByVal   fRequest   As   Long,   ByVal   lpszDriver   As   String,   ByVal   lpszAttributes   As   String)   As   Long
Private   Declare   Function   SQLDataSources   Lib   "ODBC32.DLL"   (ByVal   henv   As   Long,   ByVal   fDirection   As   Integer,   ByVal   szDSN   As   String,   ByVal   cbDSNMax   As   Integer,   pcbDSN   As   Integer,   ByVal   szDescription   As   String,   ByVal   cbDescriptionMax   As   Integer,   pcbDescription   As   Integer)   As   Integer
Private   Declare   Function   SQLAllocEnv   Lib   "ODBC32.DLL"   (env   As   Long)   As   Integer

'创建数据源       成功返回TRUE，失败返回FALSE
Public   Function   fun_CreateDSN(ByVal   DSNname   As   String,   ByVal   ODBCdriver   As   String,   ByVal   DSNtype   As   e_DSNtype,   _
                                                            ByVal   SVRname   As   String,   ByVal   DBname   As   String,   ByVal   User   As   String,   _
                                                            ByVal   pwd   As   String,   ByVal   DSNdesc   As   String)   As   Boolean
'         DSNname：数据源名
'         ODBCdriver：数据源驱动
'         DSNtype：数据源类型（系统、用户）
'         SVRname：服务器名称
'         DBname：数据库名
'         User：用户名
'         PWD：密码
'         DSNdesc：数据源描述
        On   Error   Resume   Next
        Dim   nRet   As   Long
        Dim   sAttributes   As   String
        If   DSNname   <>   ""   Then   sAttributes   =   "DSN="   &   DSNname   &   Chr$(0)
        If   DSNdesc   <>   ""   Then   sAttributes   =   sAttributes   &   "DESCRIPTION="   &   DSNdesc   &   Chr$(0)
        If   SVRname   <>   ""   Then   sAttributes   =   sAttributes   &   "SERVER="   &   SVRname   &   Chr$(0)
        If   User   <>   ""   Then   sAttributes   =   sAttributes   &   "UID="   &   User   &   Chr$(0)
        If   pwd   <>   ""   Then   sAttributes   =   sAttributes   &   "PWD="   &   pwd   &   Chr$(0)
        If   InStr(1,   LCase$(ODBCdriver),   "access")   >   0   Then
                If   DBname   <>   ""   Then   sAttributes   =   sAttributes   &   "DBQ="   &   DBname   &   Chr$(0)
        ElseIf   InStr(1,   LCase$(ODBCdriver),   "sql   server")   >   0   Then
                sAttributes   =   "DSN="   &   DSNname   &   Chr$(0)   &   "Server="   &   SVRname   &   Chr$(0)   &   _
                                        "UseProcForPrepare=Yes"   &   Chr$(0)
        Else
                If   DBname   <>   ""   Then   sAttributes   =   sAttributes   &   "DATABASE="   &   DBname   &   Chr$(0)
        End   If
        If   DSNtype   =   eSysDSN   Then
                nRet   =   SQLConfigDataSource(vbAPINull,   ODBC_ADD_SYS_DSN,   ODBCdriver,   sAttributes)
        ElseIf   DSNtype   =   eUserDSN   Then
                nRet   =   SQLConfigDataSource(vbAPINull,   ODBC_ADD_DSN,   ODBCdriver,   sAttributes)
        Else
                fun_CreateDSN   =   False
                Exit   Function
        End   If
        If   nRet   =   0   Then
                fun_CreateDSN   =   False
        Else
                fun_CreateDSN   =   True
        End   If
End   Function

'删除数据源，成功返回TRUE，失败返回FALSE
Public   Function   fun_DeleteDSN(ByVal   DSNname   As   String,   ByVal   ODBCdriver   As   String,   ByVal   DSNtype   As   e_DSNtype)   As   Boolean
'         DSNname：数据源名
'         ODBCdriver：数据源驱动
'         DSNtype：数据源类型（系统、用户）
        On   Error   Resume   Next
        Dim   nRet   As   Long
        Dim   sAttributes   As   String
        sAttributes   =   sAttributes   &   "DSN="   &   DSNname   &   Chr$(0)
        If   DSNtype   =   eSysDSN   Then
                nRet   =   SQLConfigDataSource(vbAPINull,   ODBC_REMOVE_SYS_DSN,   ODBCdriver,   sAttributes)
        ElseIf   DSNtype   =   eUserDSN   Then
                nRet   =   SQLConfigDataSource(vbAPINull,   ODBC_REMOVE_DSN,   ODBCdriver,   sAttributes)
        Else
                fun_DeleteDSN   =   False
                Exit   Function
        End   If
        If   nRet   =   0   Then
                fun_DeleteDSN   =   False
        Else
                fun_DeleteDSN   =   True
        End   If
End   Function

'搜索系统中所有的DSN(ODBC)数据源和对应的驱动         0表示失败，其余数值表示返回的驱动或数据源的数量（数组从1开始）
Public   Function   fun_GetDSNsAndDrivers(ByRef   strArr_DSNs()   As   String,   ByRef   strArr_DRVs()   As   String)   As   Long
        Dim   int_Ret   As   Integer
        Dim   sDSNItem   As   String   *   1024
        Dim   sDRVItem   As   String   *   1024
        Dim   int_I   As   Integer
        Dim   sDSN   As   String
        Dim   sDRV   As   String
        Dim   iDSNLen   As   Integer
        Dim   iDRVLen   As   Integer
        Dim   lHenv   As   Long           '对环境处理
       
        On   Error   GoTo   doError
       
        ReDim   strArr_DSNs(0)   As   String
        ReDim   strArr_DRVs(0)   As   String
        If   SQLAllocEnv(lHenv)   <>   SQL_ERROR   Then
                int_I   =   0
                sDSNItem   =   Space(1024)
                sDRVItem   =   Space(1024)
                int_Ret   =   SQLDataSources(lHenv,   SQL_FETCH_NEXT,   sDSNItem,   1024,   iDSNLen,   sDRVItem,   1024,   iDRVLen)
                Do   Until   int_Ret   <>   SQL_SUCCESS
                        sDSN   =   Left$(sDSNItem,   iDSNLen)
                        sDRV   =   Left$(sDRVItem,   iDRVLen)
                        int_I   =   int_I   +   1
                        If   int_I   =   1   Then
                                ReDim   strArr_DSNs(1   To   1)   As   String
                                ReDim   strArr_DRVs(1   To   1)   As   String
                        Else
                                ReDim   Preserve   strArr_DSNs(1   To   int_I)   As   String
                                ReDim   Preserve   strArr_DRVs(1   To   int_I)   As   String
                        End   If
                        strArr_DSNs(int_I)   =   sDSN
                        strArr_DRVs(int_I)   =   sDRV
                        sDSNItem   =   Space(1024)
                        sDRVItem   =   Space(1024)
                        int_Ret   =   SQLDataSources(lHenv,   SQL_FETCH_NEXT,   sDSNItem,   1024,   iDSNLen,   sDRVItem,   1024,   iDRVLen)
                Loop
                fun_GetDSNsAndDrivers   =   int_I
        Else
                fun_GetDSNsAndDrivers   =   0
        End   If
        Exit   Function
doError:
        fun_GetDSNsAndDrivers   =   0
End   Function