Martha, le dejo este formulario que utilizo para cambiar de empresa en mis aplicaciones, esto permite que con una sola aplicación de Access pueda administrar varias empresas utilizando en la nube un servidor de datos PostgreSQL.
El formulario permite Crear, Editar y Retirar el DSN para la empresa seleccionada.
Copie este código en un módulo
'Módulo para CREAR, EDITAR Y ELIMINAR UN DSN
'ACCESS 64 BITS
'PREPARADO POR: Eduardo Pérez Fernández
'Fecha: 12/04/2023
Private Enum HKEY_PTR
HKEY_LOCAL_MACHINE = &H80000002
End Enum
Private Const SQL_FETCH_NEXT = 1
Private Const SQL_SUCCESS = 0
Private Declare PtrSafe Function SQLConfigDataSource Lib "ODBCCP32.DLL" ( _
ByVal hwndParent As LongPtr, _
ByVal fRequest As Long, _
ByVal lpszDriver As String, _
ByVal lpszAttributes As String) As LongPtr
Private Const ODBC_ADD_DSN = 1 ' Agregar un nuevo DSN
Private Const ODBC_CONFIG_DSN = 2 ' Modificar un DSN existente
Private Const ODBC_REMOVE_DSN = 3 ' Eliminar un DSN existente
Private Declare PtrSafe Function SQLAllocHandle Lib "odbc32.dll" ( _
ByVal HandleType As Integer, _
ByVal inputHandle As LongPtr, _
ByRef OutputHandlePtr As LongPtr) As Integer
Private Declare PtrSafe Function SQLFreeHandle Lib "odbc32.dll" ( _
ByVal HandleType As Integer, _
ByVal handle As LongPtr) As Integer
Private Declare PtrSafe Function SQLDrivers Lib "odbc32.dll" ( _
ByVal hEnv As LongPtr, _
ByVal fDirection As Integer, _
ByVal szDriverDesc As String, _
ByVal cbDriverDesc As Integer, _
ByRef pcbDriverDesc As Integer, _
ByVal szDriverAttributes As String, _
ByVal cbDriverAttributes As Integer, _
ByRef pcbDriverAttributes As Integer) As Integer
Private Function DriverExists(driverName As String) As Boolean
Dim hEnv As LongPtr
Dim ret As Integer
Dim driverDesc As String * 1024
Dim driverAttributes As String * 1024
Dim cbDriverDesc As Integer
Dim cbDriverAttributes As Integer
'Inicializar el entorno ODBC
ret = SQLAllocHandle(1, 0, hEnv)
If ret <> 0 Then
DriverExists = False
Exit Function
End If
'Buscar el controlador
Ret = SQLDrivers(hEnv, 2, driverDesc, 1024, cbDriverDesc, driverAttributes, 1024, cbDriverAttributes)
While ret = 0
If InStr(driverDesc, driverName) > 0 Then
DriverExists = True
Exit Function
End If
Ret = SQLDrivers(hEnv, 2, driverDesc, 1024, cbDriverDesc, driverAttributes, 1024, cbDriverAttributes)
Wend
'Liberar los recursos utilizados
SQLFreeHandle 1, hEnv
End Function
Public Function CreatePostgreSQLDSN(ByVal DSNName As String, _
ByVal ServerName As String, _
ByVal puerto As Long, _
ByVal DatabaseName As String, _
ByVal UserName As String, _
ByVal Password As String, tipo As Byte) As Boolean
Dim lResult As LongPtr
Dim sAttributes As String
' Construir la cadena de atributos del DSN
sAttributes = "Server=" & ServerName & vbNullChar
sAttributes = sAttributes & "Port=" & puerto & vbNullChar ' El puerto por defecto es 5432
sAttributes = sAttributes & "Database=" & DatabaseName & vbNullChar
sAttributes = sAttributes & "Uid=" & UserName & vbNullChar
sAttributes = sAttributes & "Pwd=" & Password & vbNullChar
sAttributes = sAttributes & "Description=BaseDatosEmpresa" & vbNullChar
If tipo = 1 Then ' Crear el DSN
lResult = SQLConfigDataSource(0, ODBC_ADD_DSN, "PostgreSQL UNICODE", "DSN=" & DSNName & vbNullChar & sAttributes & vbNullChar)
ElseIf tipo = 2 Then ' ' Modificar un DSN existente
lResult = SQLConfigDataSource(0, ODBC_CONFIG_DSN, "PostgreSQL UNICODE", "DSN=" & DSNName & vbNullChar & sAttributes & vbNullChar)
Else
'remover DSN
lResult = SQLConfigDataSource(0, ODBC_REMOVE_DSN, "PostgreSQL UNICODE", "DSN=" & DSNName & vbNullChar & sAttributes & vbNullChar)
End If
If lResult <> 0 Then
CreatePostgreSQLDSN = True
End If
End Function
CÓDIGO DEL BOTÓN DSN
Private Sub btnDSN_Click()
Dim mDSN As Boolean
If IsNull(Me.opcDSN) Then
MsgBox "Debe indicar el proceso a realizar con el DSN", vbInformation, "Error ..."
Exit Sub
End If
mDSN = CreatePostgreSQLDSN(Me.dsn, Me.servidor, Me.puerto, Me.basedatos, Me.usuario, Me.contrasena, Me.opcDSN)
If mDSN Then
If Me.opcDSN = 1 Then
MsgBox "DSN creado satisfactoriamente", vbInformation, "DSN"
ElseIf Me.opcDSN = 2 Then
MsgBox "DSN editado satisfactoriamente", vbInformation, "DSN"
Else
MsgBox "DSN Eliminado satisfactoriamente", vbInformation, "DSN"
End If
End If
End Sub
No olvide que en cada PC debe estar instalador el controlador ODBC de PostgreSQL.
Espero le sirva, como tiene mi correo puede enviarme sus comentarios o dudas.