Crear DSN desde vb 6.0 en tiempo de ejecución

Largo ha sido el camino transitado hasta encontrar la solución a uno de mis grandes dilemas.
Ahora que ya he conseguido hacerlo, lo comparto con el mundo.

El crear DSN's de forma dinámica en tiempo de ejecución nos permite configurar y utilizar las conexiones de los controles y data reports sin miedo a futuros cambios.

El código lo he organizado en un módulo.

Descargar Módulo

view plainprint?

1. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
2. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
3. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
4. ''' Autor: Roberto Herrero                       '''''''''''''''''''''''''''''''  
5. ''' Fecha: 05/Junio/2008                         '''''''''''''''''''''''''''''''  
6. '''        http://blog-indomita.blogspot.com/    '''''''''''''''''''''''''''''''  
7. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
8. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
9. ''' Origen : Brian Plano Abad                    '''''''''''''''''''''''''''''''  
10. ''' Fecha:   20/Dic/2006 (18 Diciembre 2006)     '''''''''''''''''''''''''''''''  
11. '''          bplano@ solingest.com               '''''''''''''''''''''''''''''''  
12. '''          http://www.elguille.info/colabora/vb2006/jesus_Ejemplo_Report_Manager2.htm  
13. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
14. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
15. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
16.   
17.   
18. Option Explicit  
19.   
20. 'Constantes  
21. Private Const ODBC_ADD_DSN = 1 ' Nuevo DSN  
22. Private Const ODBC_CONFIG_DSN = 2 ' Modificar DSN  
23. Private Const ODBC_REMOVE_DSN = 3 ' Eliminar DSN  
24. Private Const ODBC_ADD_SYS_DSN = 4 ' Nuevo DSN de sistema  
25. Private Const ODBC_CONFIG_SYS_DSN = 5 ' Modificar DSN de sistema  
26. Private Const ODBC_REMOVE_SYS_DSN = 6 ' Eliminar DSN de sistema  
27. Private Const vbAPINull As Long = 0 ' Null Pointer  
28. Private Const SQL_SUCCESS As Long = 0  
29. Private Const SQL_FETCH_NEXT As Long = 1  
30.   
31. 'Declaración de funciones de API  
32. 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  
33. 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  
34. Private Declare Function SQLAllocEnv Lib "ODBC32.DLL" (Env As Long) As Integer  
35.   
36. 'Constantes  
37. 'ruta hasta el servidor (ip/nombre/ruta)  
38. Private Const C_Server = "localhost"  
39. 'usuario  
40. Private Const C_User = "usuario"  
41. 'contraseña  
42. Private Const C_Pass = "contraseña"  
43. 'base de datos  
44. Private Const C_BD = "nombre base de datos"  
45. 'puerto  
46. Private Const C_Port = 3306  
47. 'Nombre ODBC de MySql  
48. '(si no tienes ninguno instalado http://dev.mysql.com/downloads/connector/odbc/5.1.html)  
49. Public Const C_MYSQL_ODBC = "MySQL ODBC 5.1 Driver"  
50.   
51.   
52.   
53. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
54. '''' FUNCIONES  
55. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
56.   
57. 'Crea el DSN para las conexiones  
58. '(utiliza las constantes por defecto para conectarse a un servidor MySql)  
59. 'Si deseas personalizarlo o dinamizarlo deberás utilizar el resto de funciones  
60. Public Function IniciaDSN(sDSNname As String) As Boolean  
61.     'Comprobamos si existe  
62.     If ExisteDSN(sDSNname) = True Then  
63.         'Si existe lo eliminamos previamente.  
64.         If BorrarDSN(sDSNname, C_MYSQL_ODBC) = False Then  
65.             IniciaDSN = False  
66.             Exit Function  
67.         End If  
68.     End If  
69.       
70.     'Creamos el nuevo DSN.  
71.     IniciaDSN = MySQLCrearDSN(sDSNname)  
72. End Function  
73.    
74.   
75. 'Crea un DSN del sistema.  
76. Public Function CrearDSN(sDSN As String, sDriver As String, sAtributos As String, Optional sHwnd As Long = vbAPINull) As Boolean  
77.     'Creamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)  
78.     CrearDSN = CBool(SQLConfigDataSource(sHwnd, ODBC_ADD_SYS_DSN, sDriver, sAtributos))  
79. End Function  
80.   
81.   
82. 'Crea un DSN MySQL con los atributos bien seteados.  
83. Public Function MySQLCrearDSN(sDSN As String, _  
84.  Optional sServer As String = C_Server, Optional sBD As String = C_BD, _  
85.  Optional sUser As String = C_User, Optional sPass As String = C_Pass, _  
86.  Optional sPort As Integer = C_Port) As Boolean  
87.    
88.     Dim sDriver As String  
89.     Dim sAtributos As String  
90.       
91.     sDriver = C_MYSQL_ODBC  
92.     sAtributos = "DSN=" & sDSN & Chr(0)  
93.     sAtributos = sAtributos & "SERVER=" & sServer & Chr(0)  
94.       
95.     sAtributos = sAtributos & "PORT=" & sPort & Chr(0)  
96.       
97.     sAtributos = sAtributos & "DATABASE=" & sBD & Chr(0)  
98.       
99.     sAtributos = sAtributos & "USER=" & sUser & Chr(0)  
100.       
101.     sAtributos = sAtributos & "PASSWORD=" & sPass & Chr(0)  
102.       
103.     sAtributos = sAtributos & "OPTION=3" & Chr(0)  
104.       
105.     'Si queremos resetear la conexión de datos, debemos borrarlo antes  
106.     If ExisteDSN(sDSN) Then  
107.         Call BorrarDSN(sDSN, sDriver)  
108.     End If  
109.       
110.     MySQLCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)  
111.   
112. End Function  
113.   
114.   
115. 'Elimina un DSN del sistema.  
116. Public Function BorrarDSN(sDSN As String, sDriver As String, Optional sHwnd As Long = vbAPINull) As Boolean  
117.     Dim sAtributos As String  
118.     ' Borramos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)  
119.     If ExisteDSN(sDSN) Then  
120.         sAtributos = "DSN=" & sDSN & Chr(0)  
121.         BorrarDSN = CBool(SQLConfigDataSource(sHwnd, ODBC_REMOVE_SYS_DSN, sDriver, sAtributos))  
122.     Else  
123.         MsgBox ExIdioma("ModDSN_Contr1")  
124.         BorrarDSN = False  
125.     End If  
126. End Function  
127.   
128.   
129. 'Comprueba si existe un DSN en el sistema.  
130. Public Function ExisteDSN(sDSN As String) As Boolean  
131.     Dim I As Integer, j As Integer  
132.     Dim sDSNItem As String * 1024  
133.     Dim sDRVItem As String * 1024  
134.     Dim sDSNActual As String  
135.     Dim sDRV As String  
136.     Dim iDSNLen As Integer  
137.     Dim iDRVLen As Integer  
138.     Dim lHenv As Long 'controlador del entorno  
139.     Dim DSNLISTA(100)  
140.     ExisteDSN = False  
141.     For j = 1 To 52  
142.         DSNLISTA(j) = ""  
143.     Next j  
144.       
145.     j = 1  
146.     If SQLAllocEnv(lHenv) <> -1 Then  
147.         Do Until I <> SQL_SUCCESS  
148.             sDSNItem = Space(1024)  
149.             sDRVItem = Space(1024)  
150.             I = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)  
151.             sDSNActual = VBA.Left(sDSNItem, iDSNLen)  
152.             sDRV = VBA.Left(sDRVItem, iDRVLen)  
153.             If sDSN <> Space(iDSNLen) Then  
154.                 DSNLISTA(j) = sDSN  
155.                 If UCase(sDSN) = UCase(sDSNActual) Then  
156.                     ExisteDSN = True  
157.                     Exit Do  
158.                 End If  
159.             End If  
160.         Loop  
161.     End If  
162. End Function  

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Autor: Roberto Herrero                       '''''''''''''''''''''''''''''''
''' Fecha: 05/Junio/2008                         '''''''''''''''''''''''''''''''
'''        http://blog-indomita.blogspot.com/    '''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Origen : Brian Plano Abad                    '''''''''''''''''''''''''''''''
''' Fecha:   20/Dic/2006 (18 Diciembre 2006)     '''''''''''''''''''''''''''''''
'''          bplano@ solingest.com               '''''''''''''''''''''''''''''''
'''          http://www.elguille.info/colabora/vb2006/jesus_Ejemplo_Report_Manager2.htm
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Option Explicit

'Constantes
Private Const ODBC_ADD_DSN = 1 ' Nuevo DSN
Private Const ODBC_CONFIG_DSN = 2 ' Modificar DSN
Private Const ODBC_REMOVE_DSN = 3 ' Eliminar DSN
Private Const ODBC_ADD_SYS_DSN = 4 ' Nuevo DSN de sistema
Private Const ODBC_CONFIG_SYS_DSN = 5 ' Modificar DSN de sistema
Private Const ODBC_REMOVE_SYS_DSN = 6 ' Eliminar DSN de sistema
Private Const vbAPINull As Long = 0 ' Null Pointer
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_FETCH_NEXT As Long = 1

'Declaración de funciones de API
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

'Constantes
'ruta hasta el servidor (ip/nombre/ruta)
Private Const C_Server = "localhost"
'usuario
Private Const C_User = "usuario"
'contraseña
Private Const C_Pass = "contraseña"
'base de datos
Private Const C_BD = "nombre base de datos"
'puerto
Private Const C_Port = 3306
'Nombre ODBC de MySql
'(si no tienes ninguno instalado http://dev.mysql.com/downloads/connector/odbc/5.1.html)
Public Const C_MYSQL_ODBC = "MySQL ODBC 5.1 Driver"



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' FUNCIONES
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Crea el DSN para las conexiones
'(utiliza las constantes por defecto para conectarse a un servidor MySql)
'Si deseas personalizarlo o dinamizarlo deberás utilizar el resto de funciones
Public Function IniciaDSN(sDSNname As String) As Boolean
    'Comprobamos si existe
    If ExisteDSN(sDSNname) = True Then
        'Si existe lo eliminamos previamente.
        If BorrarDSN(sDSNname, C_MYSQL_ODBC) = False Then
            IniciaDSN = False
            Exit Function
        End If
    End If
    
    'Creamos el nuevo DSN.
    IniciaDSN = MySQLCrearDSN(sDSNname)
End Function
 

'Crea un DSN del sistema.
Public Function CrearDSN(sDSN As String, sDriver As String, sAtributos As String, Optional sHwnd As Long = vbAPINull) As Boolean
    'Creamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
    CrearDSN = CBool(SQLConfigDataSource(sHwnd, ODBC_ADD_SYS_DSN, sDriver, sAtributos))
End Function


'Crea un DSN MySQL con los atributos bien seteados.
Public Function MySQLCrearDSN(sDSN As String, _
 Optional sServer As String = C_Server, Optional sBD As String = C_BD, _
 Optional sUser As String = C_User, Optional sPass As String = C_Pass, _
 Optional sPort As Integer = C_Port) As Boolean
 
    Dim sDriver As String
    Dim sAtributos As String
    
    sDriver = C_MYSQL_ODBC
    sAtributos = "DSN=" & sDSN & Chr(0)
    sAtributos = sAtributos & "SERVER=" & sServer & Chr(0)
    
    sAtributos = sAtributos & "PORT=" & sPort & Chr(0)
    
    sAtributos = sAtributos & "DATABASE=" & sBD & Chr(0)
    
    sAtributos = sAtributos & "USER=" & sUser & Chr(0)
    
    sAtributos = sAtributos & "PASSWORD=" & sPass & Chr(0)
    
    sAtributos = sAtributos & "OPTION=3" & Chr(0)
    
    'Si queremos resetear la conexión de datos, debemos borrarlo antes
    If ExisteDSN(sDSN) Then
        Call BorrarDSN(sDSN, sDriver)
    End If
    
    MySQLCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)

End Function


'Elimina un DSN del sistema.
Public Function BorrarDSN(sDSN As String, sDriver As String, Optional sHwnd As Long = vbAPINull) As Boolean
    Dim sAtributos As String
    ' Borramos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
    If ExisteDSN(sDSN) Then
        sAtributos = "DSN=" & sDSN & Chr(0)
        BorrarDSN = CBool(SQLConfigDataSource(sHwnd, ODBC_REMOVE_SYS_DSN, sDriver, sAtributos))
    Else
        MsgBox ExIdioma("ModDSN_Contr1")
        BorrarDSN = False
    End If
End Function


'Comprueba si existe un DSN en el sistema.
Public Function ExisteDSN(sDSN As String) As Boolean
    Dim I As Integer, j As Integer
    Dim sDSNItem As String * 1024
    Dim sDRVItem As String * 1024
    Dim sDSNActual As String
    Dim sDRV As String
    Dim iDSNLen As Integer
    Dim iDRVLen As Integer
    Dim lHenv As Long 'controlador del entorno
    Dim DSNLISTA(100)
    ExisteDSN = False
    For j = 1 To 52
        DSNLISTA(j) = ""
    Next j
    
    j = 1
    If SQLAllocEnv(lHenv) <> -1 Then
        Do Until I <> SQL_SUCCESS
            sDSNItem = Space(1024)
            sDRVItem = Space(1024)
            I = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
            sDSNActual = VBA.Left(sDSNItem, iDSNLen)
            sDRV = VBA.Left(sDRVItem, iDRVLen)
            If sDSN <> Space(iDSNLen) Then
                DSNLISTA(j) = sDSN
                If UCase(sDSN) = UCase(sDSNActual) Then
                    ExisteDSN = True
                    Exit Do
                End If
            End If
        Loop
    End If
End Function

Fuente: elGuille.info