怎么用程序添加一个SQL的ODBC数据源

Question

在已经知道用户名和密码的情况下怎么用程序添加一个ODBC数据源

Answer 1

Option Explicit
Public Enum eDBType
  FileBased
  ServerBased
End Enum
Private Type tDSNAttrib
  Type As eDBType                 'FileBased (eg Access) or ServerBased (eg. SQL Server)
  Server As String                'Database Server
  Description As String           'Database description
  DSN As String                   'The DSN Name
  Driver As String                'The Drive name
  Database As String              'Name or path of database
  UserID As String                'The UserID
  Password As String              'The User Password
  TrustedConnection As Boolean    'If True ignore the UserID and Password as will us NT
  SystemDSN As Boolean            'If True creates a system DSN, else creates a user DSN.
End Type
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_CONFIG_SYS_DSN = 5
Private Const ODBC_REMOVE_SYS_DSN = 6
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 Function DSNCreate(tAttributes As tDSNAttrib) As Boolean
Dim lRet As Long
Dim sAttributes As String
On Error Resume Next
If tAttributes.Type = FileBased Then
   sAttributes = "DBQ=" & tAttributes.Database & vbNullChar
Else
  sAttributes = "Server=" & tAttributes.Server & vbNullChar
  sAttributes = sAttributes & "DATABASE=" & tAttributes.Database & vbNullChar
End IfsAttributes = sAttributes & "DSN=" & tAttributes.DSN & vbNullChar
If Len(tAttributes.Description) Then
   sAttributes = sAttributes & "DESCRIPTION=" & tAttributes.Description & vbNullChar
End IfIf tAttributes.TrustedConnection Then
   sAttributes = sAttributes & "Trusted_Connection=Yes" & vbNullChar
Else
   If Len(tAttributes.UserID) Then
      sAttributes = sAttributes & "UID=" & tAttributes.UserID & vbNullChar
   End If
   If Len(tAttributes.Password) Then
      sAttributes = sAttributes & "PWD=" & tAttributes.Password & vbNullChar
   End If
End If
If tAttributes.SystemDSN Then
   DSNCreate = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, tAttributes.Driver, sAttributes)
Else
   DSNCreate = SQLConfigDataSource(0&, ODBC_ADD_DSN, tAttributes.Driver, sAttributes)
End If
End FunctionPrivate Function DSNDelete(sDSN As String, sDriver As String, Optional bSystemDSN As Boolean = False) As Boolean
Dim lRet As Long
Dim sAttributes As String
On Error Resume Next
sAttributes = "DSN=" & sDSN & vbNullChar
If bSystemDSN Then
   DSNDelete = SQLConfigDataSource(0&, ODBC_REMOVE_DSN, sDriver, sAttributes)
Else
   DSNDelete = SQLConfigDataSource(0&, ODBC_REMOVE_SYS_DSN, sDriver, sAttributes)
End If
End FunctionSub Test()
Dim tDSNDetails As tDSNAttrib
'---Add an Access DSN
With tDSNDetails
.Database = "C:\vbusers.mdb"
.Driver = "Microsoft Access Driver (*.mdb)"
.Password = ""
.UserID = "Admin"
.DSN = "TestDSN"
.Description = "A Test Database"
.Type = FileBased
End With
If DSNCreate(tDSNDetails) Then
MsgBox "Created user DSN"
'Delete the new DSN
If DSNDelete(tDSNDetails.DSN, tDSNDetails.Driver) Then
MsgBox "Deleted New DSN"
Else
MsgBox "Failed to Delete New DSN"
End If
Else
MsgBox "Failed to Create DSN"
End If
'---Add an SQL Server DSN
With tDSNDetails
.Database = "Pubs"
.Driver = "SQL Server"
.Server = "MyServer"
.TrustedConnection = True    'Use NT authentication
.Password = ""
.UserID = ""
.DSN = "TestDSN2"
.Description = "A Test Database2"
.Type = ServerBased
.SystemDSN = True           'Create a System DSN
End With
If DSNCreate(tDSNDetails) Then
MsgBox "Created system DSN"
'Delete the new DSN
If DSNDelete(tDSNDetails.DSN, tDSNDetails.Driver) Then
MsgBox "Deleted New DSN"
Else
MsgBox "Failed to Delete New DSN"
End If
Else
MsgBox "Failed to Create DSN"
End If
End SubPrivate Sub Form_Load()
  Call Test
End Sub

Answer 2

哈哈，我用的是无DNS连接，将连接参数写到注册表中，用的是SQL的客户端连接程序，只需三个动态连接库

Answer 3

楼上的大师是怎么用的无DNS连接的呀 怎么把连接参数写到注册表的呀
在问楼上的楼上那哥们你的代码怎么不起作用呀 是不是不全呀

Answer 4

Public Enum e_DSNtype
    eUserDSN = 0    '用户数据源
    eSysDSN         '系统数据源
End EnumPrivate 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 = 1Private 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