Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' Este procedimiento convierte de la estructura Win32 a la estructura de MSAccess.
msaof.cadRutaCompletaDevuelta = Left$(of.lpcadArchivo, InStr(of.lpcadArchivo, vbNullChar) - 1)
msaof.cadNombreDeArchivoDevuelto = of.lpcadTítuloArchivo
msaof.entPosiciónArchivo = of.nPosiciónArchivo
msaof.entExtensiónDeArchivo = of.nExtensiónArchivo
End Sub
Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' Este procedimiento convierte de la estructura de MSAccess a la estructura de Win32.
Dim cadArchivo As String * 512
' Iniciar algunas partes de la estructura.
of.hwndPropietario = Application.hWndAccessApp
of.hInstancia = 0
of.lpcadFiltroPersonalizado = 0
of.nMáxFiltroCustr = 0
of.lpfnConexión = 0
of.lpNombrePlantilla = 0
of.lDatosCustr = 0
If msaof.cadFiltro = "" Then
of.lpcadFiltro = MSA_CreateFilterString(ALLFILES)
Else
of.lpcadFiltro = msaof.cadFiltro
End If
of.nÍndiceFiltro = msaof.lngÍndiceFiltro
of.lpcadArchivo = msaof.cadArchivoInicial & String$(512 - Len(msaof.cadArchivoInicial), 0)
of.nMáxArchivo = 511
of.lpcadTítuloArchivo = String$(512, 0)
of.nMáxTítuloArchivo = 511
of.lpcadTítulo = msaof.cadTítuloDeCuadroDeDiálogo
of.lpcadDirectorioInicial = msaof.cadDirectorioInicial
of.lpcadExtPredeterminada = msaof.cadExtensiónPredeterminada
of.indicadores = msaof.lngIndicadores
of.lTamañoEstructura = Len(of)
End Sub
Private Function ActualizarVínculos(cadNombreArchivo As String) As Boolean
' Actualizar los vínculos a la base de datos suministrada. Devolver True si no se produce ningún error.
Dim bd As Database
Dim entCuenta As Integer
Dim tdf As TableDef
' Pasar por todas las tablas de la base de datos.
Set bd = CurrentDb
For entCuenta = 0 To bd.TableDefs.Count - 1
Set tdf = bd.TableDefs(entCuenta)
' Si la tabla tiene una cadena de conexión, es una tabla vinculada.
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & cadNombreArchivo
Err = 0
On Error Resume Next
tdf.RefreshLink ' Volver a vincular la tabla.
If Err <> 0 Then
ActualizarVínculos = False
Exit Function
End If
End If
Next entCuenta
ActualizarVínculos = True ' Vinculación terminada.
End Function
Public Function VolverAVincularTablas() As Boolean
' Intentar actualizar los vínculos a la base de datos Neptuno.
' Devolver True si no se produce ningún error.
Const conMáxTablas = 8
Const conTablaNoExistente = 3011
Const conNoEsNeptuno = 3078
Const conNeptunoNoEncontrada = 3024
Const conAccesoDenegado = 3051
Const conBaseDeDatosDeSóloLectura = 3027
Const conTítuloAplicación = "Pedidos"
Dim cadDirectorioAccess As String
Dim cadRutaBúsqueda As String
Dim cadNombreArchivo As String
Dim entError As Integer
Dim cadError As String
' Obtener el nombre del directorio donde está ubicado Msaccess.exe.
cadDirectorioAccess = SysCmd(acSysCmdAccessDir)
' Obtener la ruta predeterminada de la base de datos de ejemplo.
If Dir(cadDirectorioAccess & "Ejemplos\.") = "" Then
cadRutaBúsqueda = cadDirectorioAccess
Else
cadRutaBúsqueda = cadDirectorioAccess & "Ejemplos\"
End If
' Buscar la base de datos Neptuno.
If (Dir(cadRutaBúsqueda & "Neptuno.mdb") <> "") Then
cadNombreArchivo = cadRutaBúsqueda & "Neptuno.mdb"
Else
' Imposible encontrar Neptuno. Mostrar el cuadro de diálogo Abrir archivo.
MsgBox "Imposible encontrar las tablas vinculadas de la base de datos Neptuno. Debe buscar Neptuno para poder utilizar " _
& conTítuloAplicación & ".", vbExclamation
cadNombreArchivo = BuscarNeptuno(cadRutaBúsqueda)
If cadNombreArchivo = "" Then
cadError = "Lo siento, debe buscar Neptuno para abrir " & conTítuloAplicación & "."
GoTo Salir_Falló
End If
End If
' Reparar los vínculos.
If ActualizarVínculos(cadNombreArchivo) Then ' Funcionó.
VolverAVincularTablas = True
Exit Function
End If
' Si falló, mostrar un error.
Select Case Err
Case conTablaNoExistente, conNoEsNeptuno
cadError = "El archivo '" & cadNombreArchivo & "' no contiene las tablas de Neptuno necesarias."
Case Err = conNeptunoNoEncontrada
cadError = "Imposible ejecutar " & conTítuloAplicación & " hasta que no encuentre la base de datos Neptuno."
Case Err = conAccesoDenegado
cadError = "Imposible abrir " & cadNombreArchivo & " porque es de sólo lectura o porque está ubicada en un recurso compartido de sólo lectura."
Case Err = conBaseDeDatosDeSóloLectura
cadError = "Imposible volver a vincular las tablas porque " & conTítuloAplicación & " es de sólo lectura o porque está ubicada en un recurso compartido de sólo lectura."
Case Else
cadError = Err.Description
End Select
Salir_Falló:
MsgBox cadError, vbCritical
VolverAVincularTablas = False
End Function
Espero que te sirva, sólo tienes que retocar la parte que te interese.
Un saludo
