Newsgroup: it.comp.lang.visual-basic
Titolo: Elenco DSN

Come fare per ottenere l'elenco dei DSN installati su una macchina ???
Sarebbe molto utile un esempio...
Grazie.

'creaDNS.bas
Option Explicit
Option Compare Text
Public MyDNS As String  '= "NorthWind"
Public MyDB  As String   '= "NWIND.MDB"
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
    (ByVal lpRootPath As String, _
    ByVal lpInputName As String, _
    ByVal lpOutputName As String) As Long
Public Const MAX_PATH = 260
' ODBC API
' -- ODBC Commands
Public Const ODBC_ADD_DSN = 1&
Public Const ODBC_CONFIG_DSN = 2&
Public Const ODBC_REMOVE_DSN = 3&
Public Const ODBC_ADD_SYS_DSN = 4&
Public Const ODBC_CONFIG_SYS_DSN = 5&
Public Const ODBC_REMOVE_SYS_DSN = 6&
Public Const ODBC_REMOVE_DEFAULT_DSN = 7&
' -- ODBC Error Codes
Public Const ODBC_ERROR_GENERAL_ERR = 1
Public Const ODBC_ERROR_INVALID_BUFF_LEN = 2
Public Const ODBC_ERROR_INVALID_HWND = 3
Public Const ODBC_ERROR_INVALID_STR = 4
Public Const ODBC_ERROR_INVALID_REQUEST_TYPE = 5
Public Const ODBC_ERROR_COMPONENT_NOT_FOUND = 6
Public Const ODBC_ERROR_INVALID_NAME = 7
Public Const ODBC_ERROR_INVALID_KEYWORD_VALUE = 8
Public Const ODBC_ERROR_INVALID_DSN = 9
Public Const ODBC_ERROR_INVALID_INF = 10
Public Const ODBC_ERROR_REQUEST_FAILED = 11
Public Const ODBC_ERROR_INVALID_PATH = 12
Public Const ODBC_ERROR_LOAD_LIB_FAILED = 13
Public Const ODBC_ERROR_INVALID_PARAM_SEQUENCE = 14
Public Const ODBC_ERROR_INVALID_LOG_FILE = 15
Public Const ODBC_ERROR_USER_CANCELED = 16
Public Const ODBC_ERROR_USAGE_UPDATE_FAILED = 17
Public Const ODBC_ERROR_CREATE_DSN_FAILED = 18
Public Const ODBC_ERROR_WRITING_SYSINFO_FAILED = 19
Public Const ODBC_ERROR_REMOVE_DSN_FAILED = 20
Public Const ODBC_ERROR_OUT_OF_MEM = 21
Public Const ODBC_ERROR_OUTPUT_STRING_TRUNCATED = 22
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_READ = &H20000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Public Const REG_DWORD = 4
Public Const ERROR_SUCCESS = 0&
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" _
(ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
'API Command to create a Data Source Name, not used in this example
Public Declare Function SQLCreateDataSource Lib "odbccp32.dll" (ByVal hwnd&,
ByVal lpszDS$) As Boolean
'API to modify/Edit/Create a Data Source Name
Public Declare Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hwnd
As Long, ByVal fRequest As Integer, ByVal lpszDriver As String, ByVal
lpszAttributes As String) As Boolean
Public Function CreateSQLODBC(NomeDNS As String, ServerIP As String,
NomeDatabaseSQL As String, OptSQL_Oracle As String) As Boolean
' This function setups a DSN common for remote Database servers
' Such as SQL or Oracle, keep in mind, this isnt a complete listing of
parameters
   Dim DSN           As String
   Dim Server        As String
   Dim Address       As String
   Dim Database      As String
   Dim Description   As String
   Dim Security      As String
   Dim SqlDriver     As String
   Dim SQLParameter  As String
   'Basically the DSN Name you want to have
   DSN = "DSN=" & Trim(NomeDNS)
   'The IP Addy of the server you want , if this is a remote connection
   Server = "SERVER=" & Trim(ServerIP)
   'Same as above
   Address = "ADDRESS=" & Trim(ServerIP)
   'The name of the database as known by the DB Server, such as SQL Server
   Database = "DATABASE=" & Trim(NomeDatabaseSQL)
   'An Optional Description Feild
   Description = "DESCRIPTION=" & Trim(NomeDNS)
   'This is optional, if you require a Security mode check the help files
   Security = "NETWORK=dbmssocn"
   'the next couple lines setup the Driver Text , that defines the type of
DB Drivers
   ' you are using, if its anything other than the ones I've listed, check
your DB
   ' documentation, or check the ODBC settings to see it's names
   'Also you will notice as each string peice is put together, they are
seperated by
   'VbNullChar, this gives it a Null seperated array in a sense so that the
API Command
   'can use the Parameters
   If OptSQL_Oracle = "SQL" Then
      SqlDriver = "SQL Server"
      SQLParameter = DSN & vbNullChar & Server & vbNullChar & Address &
vbNullChar & Security & vbNullChar & _
         Database & vbNullChar & Description & vbNullChar & vbNullChar
   ElseIf OptSQL_Oracle = "Oracle" Then
      SqlDriver = "Oracle73"
      SQLParameter = DSN & vbNullChar & Server & vbNullChar & Database &
vbNullChar & _
         Description & vbNullChar & vbNullChar
   End If
   'calls SQLConfigDataSource , giving it the forms handle, the command to
Add a System DSN
   'giving it the Driver name, and then the Null Seperated Parameter listing
   CreateSQLODBC = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, SqlDriver,
SQLParameter)
   'Replace 0& with Me.hwnd if you wish for users to further configure
settings such as a long
End Function
Public Function CreateAccessODBC(AccessDSN As String, FileMDB As String,
CurrP As String) As Boolean
Dim AccessParameter
'This common setup for an Access Database
   Dim Driver        As String
   Dim DSN           As String
   Dim Server        As String
   Dim Database      As String
   Dim Description   As String
   Dim AccessPathMDB As String
   If Trovadns(AccessDSN) = True Then
        CreateAccessODBC = True
        Exit Function
   End If
   If Dir(CurrP & "\" & MyDB) = "" Then
        AccessPathMDB = FindFile("C:\", FileMDB)
   Else
        AccessPathMDB = CurrP & MyDB
   End If
   If AccessPathMDB = "" Then
    CreateAccessODBC = False
    Exit Function
   End If
   DSN = "DSN=" & Trim(AccessDSN)
   Database = "DBQ=" & Trim(AccessPathMDB) 'this is your physical path to
the *.mdb
   Description = "DESCRIPTION=" & Trim(AccessDSN)
   AccessParameter = DSN & vbNullChar & Database & vbNullChar & Description
& vbNullChar & vbNullChar
   CreateAccessODBC = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, "Microsoft
Access Driver (*.mdb)", AccessParameter)
End Function
Public Function FindFile(RootPath As String, _
    FileName As String) As String
    Dim fso As FileSystemObject
    Dim lNullPos As Long
    Dim lResult As Long
    Dim sBuffer As String
    Dim Drive As Drive
    On Error GoTo FileFind_Error
    'Allocate buffer
    sBuffer = Space(MAX_PATH * 2)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Drive In fso.Drives
    'Find the file
    lResult = SearchTreeForFile(RootPath, FileName, sBuffer)
    'Trim null, if exists
    If lResult Then
        lNullPos = InStr(sBuffer, vbNullChar)
        If Not lNullPos Then
            sBuffer = Left(sBuffer, lNullPos - 1)
        End If
        'Return filename
        FindFile = sBuffer
        Exit Function
    Else
        'Nothing found
        FindFile = vbNullString
    End If
Next
    Exit Function
FileFind_Error:
    FindFile = vbNullString
End Function
'-- The subroutine FillODBCCombo is called when the Properties form is
loaded.
'-- First the root ODBC key is opened. By iterating through its sub-keys,
'-- all of the installed DNS's are found and inserted into the DNS ComboBox.
Public Function Trovadns(MyDNS As String) As Boolean
Dim hKey As Long
Dim dwIndex As Long
Dim lpData As Long
Dim lpcbData As Long
Dim lngResult As Long
Dim strResult As String
Dim lpValueName As String
Dim lpcbValueName As Long
lngResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\ODBC\ODBC.INI\ODBC
Data Sources", 0&, KEY_READ, hKey)
If lngResult <> ERROR_SUCCESS Then
MsgBox "Error opening ODBC registry key."
Exit Function
End If
dwIndex = 0
'-- Add each DNS to the combo
Do
lpcbValueName = 1000
lpcbData = 1000
lpValueName = String(lpcbValueName, 0)
'-- The RegEnumValue function allows you to
'-- move through the subkeys one at a time
lngResult = RegEnumValue(hKey, dwIndex, ByVal lpValueName, lpcbValueName,
0&, REG_DWORD, ByVal lpData, lpcbData)
If lngResult = ERROR_SUCCESS Then
    strResult = Left(lpValueName, lpcbValueName)
    If strResult = MyDNS Then
        Trovadns = True
        Exit Function
    End If
End If
dwIndex = dwIndex + 1
Loop While lngResult = ERROR_SUCCESS
RegCloseKey hKey
Trovadns = False
End Function
' convert a string so that it can be used on a URL path
'
' Same effect as the Server.URLPathEncode method in ASP
Public Function URLPathEncode(ByVal Text As String) As String
    Dim i As Integer
    Dim acode As Integer
    URLPathEncode = Text
    For i = Len(URLPathEncode) To 1 Step -1
        acode = Asc(Mid$(URLPathEncode, i, 1))
        Select Case acode
            Case 48 To 57, 65 To 90, 97 To 122
                ' don't touch alphanumeric chars
            Case 33, 35, 36, 38, 42, 43, 45, 46, 47, 58, 63, 64, 95, 126
                ' these punctuation chars require no translation
            Case Else
                ' replace other chars with "%hex"
                URLPathEncode = Left$(URLPathEncode, i - 1) & "%" &
Hex$(acode) _
                    & Mid$(URLPathEncode, i + 1)
        End Select
    Next
End Function

Grazie!