Visual Basic - como creo un dsn de sistema por código

Pues eso, como puedo hacer eso mediante código. En su defecto que se cree mediante el empaquetador al instalar el programa.

Eso que pides no se si se pueda hacer con codigo y mas que nada con el instalador. Yo en lo personal no utilizo DNS asi como tu pides ya que hay que ponerlos manualmente en el Panel de Control.. etc.. No se si te sirva pero yo lo utilizo asi

Public Conexion As ADODB.Connection

Set Conexion = New ADODB.Connection

Conexion.CursorLocation = adUseClient
Conexion.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver};" _
& "SERVER=" & Host & ";" _
& "DATABASE=mysql;" _
& "UID=" & Usuario & ";" _
& "PWD=" & Clave & ";" _
& "OPTION=" & 1 + 2 + 8 + 32 + 2048 + 16384
Conexion.Open
Conexion.Execute "CREATE DATABASE IF NOT EXISTS SisteLopezPuerta"
Conexion.Close

Claro, el Conexion se puede quedar abierto

SI SE PUEDE, yo ya logré como ponerlo por código, el problema es que no se cómo quitarlo, igual por código.

Se hace así:

'CREA UN MODULO Y PON ESTO:
Private Const KEY_QUERY_VALUE = &H1
Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1
'Private Const HKEY_CURRENT_USER = &H80000002
Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_DWORD = 4
Private 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
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public bandera_modulo As Byte
Public Archivo_Agregado As String

Public Function isSZKeyExist(szKeyPath As String, _
szKeyName As String, _
ByRef szKeyValue As String) As Boolean
Dim bRes As Boolean
Dim lRes As Long
Dim hKey As Long
lRes = RegOpenKeyEx(HKEY_CURRENT_USER, _
szKeyPath, _
0&, _
KEY_QUERY_VALUE, _
hKey)
If lRes <> ERROR_SUCCESS Then
isSZKeyExist = False
Exit Function
End If
lRes = RegQueryValueEx(hKey, _
szKeyName, _
0&, _
REG_SZ, _
ByVal szKeyValue, _
Len(szKeyValue))
RegCloseKey (hKey)
If lRes <> ERROR_SUCCESS Then
isSZKeyExist = False
Exit Function
End If
isSZKeyExist = True
bandera_modulo = 0
If isSZKeyExist Then bandera_modulo = 1
End Function

Public Function checkAccessDriver(ByRef szDriverName As String) As Boolean
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean
bRes = False
szKeyPath = "SOFTWARE\ODBC\ODBCINST.INI\Microsoft Access Driver (*.mdb)"
szKeyName = "Driver"
szKeyValue = String(255, Chr(32))
If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
szDriverName = szKeyValue
bRes = True
Else
bRes = False
End If
checkAccessDriver = bRes
End Function

Public Function checkWantedAccessDSN(szWantedDSN As String) As Boolean
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean
'HKEY_CURRENT_USER\Software\ODBC\ODBC.INI
'HKEY_CURRENT_USER\SOFTWARE\ODBC\ODBC.INI
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources"
szKeyName = szWantedDSN
szKeyValue = String(255, Chr(32))
If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
bRes = True
Else
bRes = False
End If
checkWantedAccessDSN = bRes
End Function

Public Function createAccessDSN(szDriverName As String, _
szWantedDSN As String) As Boolean
Dim hKey As Long
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim lKeyValue As Long
Dim lRes As Long
Dim lSize As Long
Dim szEmpty As String
szEmpty = Chr(0)
lSize = 4
lRes = RegCreateKey(HKEY_CURRENT_USER, _
"SOFTWARE\ODBC\ODBC.INI\" & _
szWantedDSN, _
hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
lRes = RegSetValueExString(hKey, "UID", 0&, REG_SZ, _
szEmpty, Len(szEmpty))
szKeyValue = "\ruta_de_archivos\" & Archivo_Agregado
lRes = RegSetValueExString(hKey, "DBQ", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
szKeyValue = szDriverName
lRes = RegSetValueExString(hKey, "Driver", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
szKeyValue = "MS Access;"
lRes = RegSetValueExString(hKey, "FIL", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
lKeyValue = 25
lRes = RegSetValueExLong(hKey, "DriverId", 0&, REG_DWORD, _
lKeyValue, 4)
lKeyValue = 0
lRes = RegSetValueExLong(hKey, "SafeTransactions", 0&, REG_DWORD, _
lKeyValue, 4)
lRes = RegCloseKey(hKey)
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
lRes = RegCreateKey(HKEY_CURRENT_USER, _
szKeyPath, _
hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
lRes = RegSetValueExString(hKey, "ImplicitCommitSync", 0&, REG_SZ, _
szEmpty, Len(szEmpty))
szKeyValue = "Yes"
lRes = RegSetValueExString(hKey, "UserCommitSync", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
lKeyValue = 2048
lRes = RegSetValueExLong(hKey, "MaxBufferSize", 0&, REG_DWORD, _
lKeyValue, 4)
lKeyValue = 5
lRes = RegSetValueExLong(hKey, "PageTimeout", 0&, REG_DWORD, _
lKeyValue, 4)
lKeyValue = 3
lRes = RegSetValueExLong(hKey, "Threads", 0&, REG_DWORD, _
lKeyValue, 4)
lRes = RegCloseKey(hKey)
lRes = RegCreateKey(HKEY_CURRENT_USER, _
"SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", _
hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
szKeyValue = "Microsoft Access Driver (*.mdb)"
lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
lRes = RegCloseKey(hKey)
createAccessDSN = True
End Function

Public Sub Agrega_DNS(ByVal szWantedDSN As String, ByVal Agregar As String)
Dim szDriverName As String
'Dim szWantedDSN As String
szDriverName = String(255, Chr(32))
Archivo_Agregado = Agregar
'is access drivers installed?
'If Not checkAccessDriver(szDriverName) Then
' MsgBox "You must Install Access ODBC Drivers before use this program.", vbOK + vbCritical
'End If
'is our dsn exist?
'If Not (checkWantedAccessDSN(szWantedDSN)) Then
If Not checkWantedAccessDSN(szWantedDSN) Then
If szDriverName = "" Then
MsgBox "Can't find access ODBC driver.", vbOK + vbCritical
Else
preg = createAccessDSN(szDriverName, szWantedDSN)
If Not preg Then
MsgBox "Can't create database ODBC.", vbOK + vbCritical
Else
MsgBox "DNS creado"
End If
End If
Else
MsgBox "DNS ya Existe"
End If
End Sub

YA EN EN TU PROGRAMA DONDE QUIERAS PON ESTO
Call Agrega_DNS(NomDNS, NomMDB)

donde NomDNS es el nombre que le vas a asignar al DNS
y NomMDB es el archivo en Access, previamente creado.

Esto funciona cuando el archivo es de Access, si acaso es otra tu plataforma tienes que buscarle un poco para saber cómo se hace

Me avisas si acaso tienes dudas, SUERTE