FAQ's de VB6

[zabait]

Problema:
GEstionar, Crear, Modificar... ODBC desde el código

Solución:
Este .bas en el que se detallan funciones para gestionar todo esto.
Copiar todo el siguiente código y meterlo en un .bas en vuestro proyecto, y simplemente solo os queda llamar a las funciones.

Siento haber tardado en poner esta FAQ, pero más vale tarde uqe nunca, verdad????

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

Function FoxCrearDSN(sDSN As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "Microsoft Visual FoxPro Driver"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SourceType=DBF" & Chr(0)
'sAtributos = sAtributos & "Collate=Machine" & Chr(0)
'sAtributos = sAtributos & "Exclusive=No" & Chr(0)
'sAtributos = sAtributos & "Deleted=Yes" & Chr(0)
'sAtributos = sAtributos & "Null=Yes" & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "SourceDB=" & sDatabase & Chr(0)
End If
' Si queremos quitar la base de datos, debemos borrarlo antes
If ExisteDSN(sDSN) Then
Call BorrarDSN(sDSN, sDriver)
End If
FoxCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)

End Function

Function FoxModificarDSN(sDSN As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "Microsoft Visual FoxPro Driver"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SourceType=DBF" & Chr(0)
'sAtributos = sAtributos & "Collate=Machine" & Chr(0)
'sAtributos = sAtributos & "Exclusive=No" & Chr(0)
'sAtributos = sAtributos & "Deleted=Yes" & Chr(0)
'sAtributos = sAtributos & "Null=Yes" & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "SourceDB=" & sDatabase & Chr(0)
End If
' Debido a que si no especificamos un atributo existente, el atributo
' original se conserva, a veces es mejor borrar el DSN y volverlo a
' crear
FoxModificarDSN = ModificarDSN(sDSN, sDriver, sAtributos)

End Function
Function FoxBorrarDSN(sDSN As String) As Boolean

Dim sDriver As String

sDriver = "Microsoft Visual FoxPro Driver"
FoxBorrarDSN = BorrarDSN(sDSN, sDriver)

End Function

Function SQLCrearDSN(sDSN As String, sServidor As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "SQL Server"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SERVER=" & sServidor & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "DATABASE=" & sDatabase & Chr(0)
End If
' Si queremos quitar la base de datos, debemos borrarlo antes
If ExisteDSN(sDSN) Then
Call BorrarDSN(sDSN, sDriver)
End If
SQLCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)

End Function

Function SQLModificarDSN(sDSN As String, sServidor As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "SQL Server"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SERVER=" & sServidor & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "DATABASE=" & sDatabase & Chr(0)
End If
' Debido a que si no especificamos un atributo existente, el atributo
' original se conserva, a veces es mejor borrar el DSN y volverlo a
' crear
SQLModificarDSN = ModificarDSN(sDSN, sDriver, sAtributos)

End Function
Function SQLBorrarDSN(sDSN As String) As Boolean

Dim sDriver As String

sDriver = "SQL Server"
SQLBorrarDSN = BorrarDSN(sDSN, sDriver)

End Function

Function CrearDSN(sDSN As String, sDriver As String, sAtributos As String) As Boolean

' Atributos
'
' DSN=SQL & Chr(0)
' SERVER=SQLSERVER & Chr(0)
' DESCRIPTION=Conexión SQL Server & Chr(0) ' Opcional
' DATABASE=ACERIA & Chr(0) ' Opcional

' Creamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
CrearDSN = CBool(SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, sDriver, sAtributos))

End Function

Function ModificarDSN(sDSN As String, sDriver As String, sAtributos As String) As Boolean

' Atributos
'
' DSN=SQL & Chr(0)
' SERVER=SQLSERVER & Chr(0)
' DESCRIPTION=Conexión SQL Server & Chr(0) ' Opcional
' DATABASE=ACERIA & Chr(0) ' Opcional

' Modificamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
If ExisteDSN(sDSN) Then
ModificarDSN = CBool(SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, sDriver, sAtributos))
Else
MsgBox "No existe el DSN"
ModificarDSN = False
End If

End Function

Function BorrarDSN(sDSN As String, sDriver As String) 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(vbAPINull, ODBC_REMOVE_SYS_DSN, sDriver, sAtributos))
Else
MsgBox "No existe el DSN"
BorrarDSN = False
End If

End Function

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