Option Compare Database
Option Explicit
Public Type OPENFILENAME
lStructSize As Long
#If Win64 Then
hwndOwner As LongPtr
hInstance As LongPtr
#Else
hwndOwner As Long
hInstance As Long
#End If
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
#If Win64 Then
lpfnHook As LongPtr
#Else
lpfnHook As Long
#End If
lpTemplateName As Long
End Type
#If Win64 Then
'para Access 64 bits
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
#Else
'para Access 32 bits
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
#End If
Global Const PorQue As String = "¿ "
Global Const Hoooo As String = "¡ "
Function MSA_ConvertirCadenaFiltro(strFilterIn As String) As String
' Crear una cadena de filtro a partir de una cadena separada por barras ("|").
' La cadena debe tener cadenas filtro|extensión, por ejemplo "Bases de datos de Access|*.mdb|Todos los archivos|*.*"
' Si no existe ninguna extensión para el último filtro, agregar *.*.
' Este código ignorará las cadenas vacías, por ejemplo "||".
' Devolver "" si la cadena pasada está vacía.
Dim cadFiltro As String
Dim entNúm As Integer, entPos As Integer, entÚltimaPosición As Integer
cadFiltro = ""
entNúm = 0
entPos = 1
entÚltimaPosición = 1
' Agregar cadenas a medida que se encuentran barras.
' Ignorar las cadenas vacías (no permitidas).
Do
entPos = InStr(entÚltimaPosición, strFilterIn, ";")
If (entPos > entÚltimaPosición) Then
cadFiltro = cadFiltro & Mid(strFilterIn, entÚltimaPosición, entPos - entÚltimaPosición) & vbNullChar
entNúm = entNúm + 1
entÚltimaPosición = entPos + 1
ElseIf (entPos = entÚltimaPosición) Then
entÚltimaPosición = entPos + 1
End If
Loop Until (entPos = 0)
' Obtener la última cadena si existe (asumiendo que strFilterIn no terminaba con una barra).
entPos = Len(strFilterIn)
If (entPos >= entÚltimaPosición) Then
cadFiltro = cadFiltro & Mid(strFilterIn, entÚltimaPosición, entPos - entÚltimaPosición + 1) & vbNullChar
entNúm = entNúm + 1
End If
' Agregar *.* si no hay niguna extensión para la última cadena.
If entNúm Mod 2 = 1 Then
cadFiltro = cadFiltro & "*.*" & vbNullChar
End If
' Agregar NULL al final si hay algún filtro.
If cadFiltro <> "" Then
cadFiltro = cadFiltro & vbNullChar
End If
MSA_ConvertirCadenaFiltro = cadFiltro
End Function
Public Function BuscaDir(ByVal strTitle As String) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
(Application.hWndAccessApp, strTitle, 1, "")
If objFolder Is Nothing Then
BuscaDir = "0"
Else
Set objFolderItem = objFolder.Self
BuscaDir = objFolderItem.Path
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Public Function ExisteFile(ByVal StFile, Optional VAttrFile = vbNormal) As Boolean
Dim NombreDeArchivo As String
Dim ExisteArchivo As String
On Error GoTo ExisteFile_Error
If (Nz(StFile, "") = "") Or (Nz(StFile, "") = ".") Or (Nz(StFile, "") = Chr$(160)) Then
ExisteFile = False
Exit Function
End If
NombreDeArchivo = Nz(StFile, "")
ExisteArchivo = Dir(NombreDeArchivo, VAttrFile)
ExisteFile = (Nz(ExisteArchivo, "") <> "")
ExisteFile_Exit:
Exit Function
ExisteFile_Error:
ExisteFile = False
Resume ExisteFile_Exit
End Function
Public Function GetMyFile(ByVal strTitle As String, StFiltX As String) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
OpenFile.lpstrFilter = MSA_ConvertirCadenaFiltro(StFiltX)
OpenFile.nFilterIndex = 1
OpenFile.hwndOwner = Application.hWndAccessApp '0
OpenFile.lpstrFile = String(257, 0)
#If Win64 Then
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)
#Else
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = Len(OpenFile)
#End If
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = ""
OpenFile.lpstrTitle = strTitle
OpenFile.Flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
GetMyFile = ""
Else
GetMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
'A esta función se le pasa como parámetros: la ruta del archivo que contiene las tablas y la clave en caso de que tenga
Private Function ActualizarVínculos(cadNombreArchivo As String, Optional ByVal StKey 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 tdf As TableDef
' Comprobar todas las tablas de la base de datos.
Dim stDocName As String
Dim stLinkCriteria As String
On Error Resume Next
Set bd = CurrentDb
For Each tdf In bd.TableDefs
' Si la tabla tiene una cadena de conexión, es una tabla vinculada.
If (Len(tdf.Connect) > 0) And (Left(tdf.Name, 1) <> "~") Then
tdf.Connect = ";PWD=" & StKey & ";DATABASE=" & cadNombreArchivo
err = 0
tdf.RefreshLink ' Volver a vincular la tabla.
If err <> 0 Then
ActualizarVínculos = False
MsgBox "Ocurrió un error al buscar la tabla" & " " & tdf.Name, vbOKOnly + vbCritical, Hoooo & "Error …" & " !"
Exit Function
End If
End If
Next tdf
ActualizarVínculos = True ' Vinculación terminada.
End Function
Public Function VolverAVincularTablas(Optional ByVal Dir_Ini As String = "", Optional ByVal CaminoAVincular As String = "", Optional ByVal KeyBD As String = "") As Boolean
' Intentar actualizar los vínculos a la base de datos
' Devolver True si no se produce ningún error.
Dim cadDirectorioAccess As String
Dim cadRutaBúsqueda As String
Dim cadNombreArchivo As String
Const conTablasMáximas = 8
Const conTablaNoExistente = 3011
Const conNoEsNeptuno = 3078
Const conNeptunoNoEncontrada = 3024
Const conAccesoDenegado = 3051
Const conBaseDeDatosDeSóloLectura = 3027
Const conTítuloAplicación = "Base de Datos ..."
Dim ExtBD As String
Dim cadError As String
ExtBD = "Base de Datos MS-Access 2003;*.MDB;Base de Datos MS-Access 2007 o Superior;*.ACCDB;Todos;*.*"
If Len(CaminoAVincular) > 0 Then
If ExisteFile(CaminoAVincular) Then
cadNombreArchivo = CaminoAVincular
GoTo Vincula
End If
End If
cadRutaBúsqueda = ""
cadNombreArchivo = GetMyFile(PorQue & "Dónde está la Base de Datos" & " ?", ExtBD)
If cadNombreArchivo = "" Then
cadError = "Debe buscar los datos de la " & conTítuloAplicación & "."
GoTo Salir_Falló
End If
Vincula:
If ExisteFile(cadNombreArchivo) Then
' Reparar los vínculos.
If ActualizarVínculos(cadNombreArchivo, KeyBD) Then
VolverAVincularTablas = True
Exit Function
End If
Else
MsgBox "El Fichero Base de Datos no Existe ...."
End If
' Si falló, mostrar un error.
Select Case err
Case conTablaNoExistente, conNoEsNeptuno
cadError = "El archivo '" & cadNombreArchivo & "' no contiene las tablas necesarias del sistema."
Case err = conNeptunoNoEncontrada
cadError = "Imposible ejecutar " & conTítuloAplicación & " hasta que busque los datos."
Case err = conAccesoDenegado
cadError = "Imposible abrir " & cadNombreArchivo & " porque es de sólo lectura o 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 está ubicada en un recurso compartido de sólo lectura."
Case Else
cadError = err.Description
End Select
Salir_Falló:
MsgBox cadError, vbCritical
VolverAVincularTablas = False
Resume
End Function
Tweet
Módulo para Revincular
Opciones del Tema
