Για την απαρίθμηση των System DSNs βρήκα αυτό που δεν το έχω δοκιμάσει, από εδώ:
http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21450287.html
Λογω έλλειψης χρονου δεν το δοκίμασα. Φυσικά δεν είμαι σίγουρος οτι θα δουλέψει, αλλά μια δοκιμή θα μας πείσει :)
Private Declare Function SQLGetDiagRec Lib "odbc32" ( _
ByVal HandleType As Integer, _
ByVal Handle As Long, _
ByVal RecNumber As Integer, _
ByVal SQLState As String, _
ByRef NativeErrorPtr As Long, _
ByVal MessageText As String, _
ByVal BufferLength As Integer, _
ByRef TextLengthPtr As Integer) _
As Integer
Private Declare Function SQLAllocHandle Lib "odbc32" ( _
ByVal HandleType As Integer, _
ByVal InputHandle As Long, _
ByRef OutputHandle As Long _
) As Integer
Private Declare Function SQLFreeHandle Lib "odbc32" ( _
ByRef HandleType As Integer, _
ByRef Handle As Long _
) As Integer
Private Declare Function SQLSetEnvAttrInteger Lib "odbc32" Alias "SQLSetEnvAttr" ( _
ByVal EnvironmentHandle As Long, _
ByVal Attr As Integer, _
ByVal Value As Long, _
ByVal StringLength As Integer) _
As Integer
Private Declare Function SQLDataSources Lib "odbc32" ( _
ByVal EnvironmentHandle As Long, _
ByVal Direction As Integer, _
ByVal ServerName As String, _
ByVal BufferLength1 As Integer, _
ByRef NameLength1 As Integer, _
ByVal Description As String, _
ByVal BufferLength2 As Integer, _
ByRef NameLength2 As Integer _
) As Integer
Private Const SQL_SUCCESS = 0
Private Const SQL_ERROR = -1
Private Const SQL_HANDLE_ENV = 1
Private Const SQL_ATTR_ODBC_VERSION = 200
Private Const SQL_OV_ODBC2 = 2
Private Const SQL_FETCH_NEXT = 1
Private Const SQL_FETCH_FIRST = 2
Public Sub GetDSNList(frm As Form)
On Error GoTo errHandler
'[Declarations]
Dim hEnv As Long 'ODBC Environment Handle
Dim intSQLReturn As Integer
Dim strServerName As String * 255
Dim intServerNameLen As Integer
Dim strDescription As String * 255
Dim intDescriptionLen As Integer
'[Code]
'Build a new list of available DSN
frm.cboDSN.Clear
If SQLAllocHandle(SQL_HANDLE_ENV, 0, hEnv) = SQL_ERROR Then
'Failed to allocate Environment Handle
Err.Raise vbObjectError + 1, "EBDSNCombo_Refresh", "Unable to allocate an ODBC Environment Handle"
Else
'We have an Environment handle
'- Inform the Driver Manager that we need ODBC2 conformance
If SQLSetEnvAttrInteger(hEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC2, 0) = -1 Then
'Failed to set conformance level
Err.Raise vbObjectError + 2, "EBDSNCombo_Refresh", "Unable to set ODBC2 conformance"
Else
'We have set the conformance level
'- Fetch a list of ODBC data sources
'Attempt to fetch first DSN
intSQLReturn = SQLDataSources(hEnv, SQL_FETCH_FIRST, strServerName, Len(strServerName), intServerNameLen, strDescription, Len(strDescription), intDescriptionLen)
Do While intSQLReturn = SQL_SUCCESS
If Len(strDriverFilter) = 0 _
Or Left(strDescription, intDescriptionLen) = strDriverFilter Then
'This data source matches the DriverFilter property (or
'DriverFilter not set)
'- Add it to the list
frm.cboDSN.AddItem Left(strServerName, intServerNameLen)
End If
'Attempt to fetch the next DSN (if any)
intSQLReturn = SQLDataSources(hEnv, SQL_FETCH_NEXT, strServerName, Len(strServerName), intServerNameLen, strDescription, Len(strDescription), intDescriptionLen)
Loop
End If
'Free the environment handle
SQLFreeHandle SQL_HANDLE_ENV, hEnv
End If
If frm.cboDSN.ListCount > 0 Then
frm.cboDSN.ListIndex = 0
End If
Exit Sub
errHandler:
Dim sTemp As String
sTemp = "An error occured retrieving the ODBC Data Source Names. The error information is as follows:"
sTemp = sTemp & vbCrLf & "Error Number: " & Err.Number
sTemp = sTemp & vbCrLf & "Error Description: " & Err.Description
AddItemToStatus sTemp
MsgBox sTemp, vbCritical, "Error during initialization!"
End Sub
Σωτήρης Φιλιππίδης
DotSee Web Services
