'Francisco García Aguado (bhuo)
'Agosto de 2002
'Proceso:
'Se trata de una base de datos Aplicacion.Mdb que tiene tablas vinculadas en una ruta
'concreta, por ejemplo C:\RutaDatos\Datos.mdb
'Si se cambia de ubicacion el modulo de datos, los puestos de trabajo en RED cuando
'ejecuten sus respectivos programas, caeran en error, pues la ruta de los
'datos ha cambiado
'¿Que hacer?
' Primero se intenta abrir una tabla vinculada cualquiera. En este ejemplo
'la tabla se llama 'Vincula'
'Si la vinculacion esta OK, se continua con la carga normal del programa
'Si la vinculacion se ha roto, se invita al usuario a escoger
'nueva ruta de vinculacion y consecuentemente se refrescan los link's
'hacia esa nueva ruta.
'ES MUY CONVENIENTE QUE TODOS IMPLEMENTEIS ESTE TIPO DE SISTEMA
'DE ALERTA EN CUALQUIER APLICACION QUE TENGA SEPARADOS LOS FORMULARIOS
' DE LOS DATOS.
'En el formulario de inicio de la aplicacion, lo primero que se hace es llamar
' a la funcion Comprobar() escrita esn este nodulo
'Comenzamos....
Option Compare Database
Option Explicit
'=================Comprobar Vinculos================
Public Function Comprobar()
'Esta funcion es llamada nada mas arrancar la aplicacion, antes de cargar ningun
'objeto de Acces. La carga se realizará bien desde una macro
'autoexec, bien desde el primer formulario de inicio de la aplicacion.-
'Escojo al hazar cualquier tabla vinculada de la aplicacion.
'Intento abrirla, si puedo...
'Si la vinculacion es OK, no se desencadena ningun evento, simplemente
'se sale de la función y continua la carga del programa normalmente.-
'Si me da error:
'la vinculacion se ha roto (Errores nº3024,3044)
'Al saltar a la rutina de tratamientos de errores, se desencadena
'todo el proceso de Vincular de nuevo los chismes con los datos..
On Error GoTo Err_Comando7_Click
Dim dbs As Database
Dim Rst As Recordset
Set dbs = CurrentDb
' en este caso Vincula es una tabla vinculada...intento abrirla...
Set Rst = dbs.OpenRecordset("Select * from Vincula", dbOpenDynaset)
Rst.Close
dbs.Close
'Si llego aquí es que la vinculacion, al menos de las tablas antiguas, esta bien....
'y me salgo de esta funcion para continuar con la carga normal del programa
MsgBox "Las tablas están perfectamente vinculadas", vbInformation + vbOKOnly, "AVISO"
Exit_Comando7_Click:
Exit Function
Err_Comando7_Click:
If Err.Number = 3024 Or Err.Number = 3044 Then
' Se ha roto la vinculación...llamo a la rutina para
'revincular...
VincularTablas
Exit Function
End If
MsgBox "El proceso NO HA TENIDO EXITO: 983-000000", vbCritical + vbOKOnly, "Servicio de Mantenimiento."
' Salida de la aplicación
Exit Function
Resume Exit_Comando7_Click
End Function
'======Funcion que refresca los Links
Function VincularTablas()
On Error GoTo Err_Comando7_Click
Dim Ejecuta As String
If MsgBox("El programa no ha podido encontrar los Datos de la Aplicación." & Chr(13) _
& "Las posibles causas pueden ser, que bien el módulo de datos se ha borrado" & Chr(13) _
& "o bien que Vd. está trabajando en RED y es necesario VINCULAR los datos desde" & Chr(13) _
& "este puesto de trabajo. Si lo desea, puede ponerse en contacto con el " & Chr(13) _
& "servicio de Mantenimiento del programa: 983-000000", vbCritical + vbYesNo, "FALTAN LOS DATOS") = vbYes Then
MsgBox "Hemos visto como el propio programa ha detectado una tabla, la cual se ha roto" & Chr(13) & Chr(10) _
& "su vinculación. En concreto la base de datos se llama Vincula.Mdb y deberá buscarla" & Chr(13) & Chr(10) _
& "en su disco duro, entorno de red etc. Una vez escogida, se realiza la RE-vinculación" & Chr(13) & Chr(10) _
& "de forma automática. Ahora pulse aceptar para seguir con el proceso.", vbInformation + vbOKOnly, "Esto ha funcionado bien"
Dim objAcObj As AccessObject
Dim objCurData As CurrentData
Dim DBSS As Database
Set objCurData = Application.CurrentData
Dim RutaFichero As String
Dim Tabla As TableDef
'En la siguiente línea llamamos al OpenCommDlg para que el usurio interaciones
'con el programa y escoja la nueva ruta donde se encuentran
'las tablas vinculadas, bien en el PC actual, bien en el entorno de RED
'AQUI:
RutaFichero = OpenCommDlg(CurrentProject.Path)
If Len(RutaFichero) <> 0 Then
Set DBSS = CurrentDb()
For Each objAcObj In objCurData.AllTables
Set Tabla = DBSS.TableDefs(objAcObj.Name)
If Tabla.Attributes And dbSystemObject Or Tabla.Name = "Ayuda" Or Tabla.Name = "barras" Or Tabla.Name = "clientedocumentos" Or Tabla.Name = "clientes" Or Tabla.Name = "codificaciones" Or Tabla.Name = "excel" Or Tabla.Name = "menu1" Or Tabla.Name = "menu2" Or Tabla.Name = "menu3" Or Tabla.Name = "menu4" Or Tabla.Name = "reemplazacodigos" Or Tabla.Name = "reporteimpresora" Or Tabla.Name = "Almacen" Or Tabla.Name = "menus" Then
'en este if quito las tablas del sistema y todas aquellas que sean locales
'que obviamente no son necesarias vincular.
'En nuestro caso, las locales son las citadas anteriormente
'ya que la MDB puede tener tablas locales (Que obviamente no son precisas vincular).
'y tener tablas vinculadas, que son las que se recogerían
'en el ELSE siguiente.
Else
Tabla.Connect = ";DATABASE=" & RutaFichero
Tabla.RefreshLink
End If
Next objAcObj
MsgBox "El proceso ha concluido con éxito. Ya tiene de nuevo vinculada" & Chr(13) _
& "la tabla VINCULA de la base de datos Vincula" & Chr(13) _
& "La Ruta de sus datos es: " & RutaFichero, vbInformation + vbOKOnly, "Proceso Concluido"
Exit Function
End If
Else
'código de salida de la aplicacion pues el proceso no ha concluido con exito.
Quit
End If
Exit_Comando7_Click:
Exit Function
Err_Comando7_Click:
MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, "Error de Datos"
Resume Exit_Comando7_Click
End Function
'=================Funcion para abrir el dialogo de Windows
'=================y que el usuario escoja ruta de vinculacion
'Al ser funciones de proposito general, esto se puede incluir
'perfectamente en otro modulo independiente
Option Compare Database
Option Explicit
Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long
'
Dim OPENFILENAME As tagOPENFILENAME
Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Function OpenCommDlg(Ruta)
On Error GoTo Err_TodoError
Dim Message$, FileName$, FileTitle$, DefExt$, Filter$
Dim Title$, szCurDir$, APIResults&
'
Filter$ = "Ficheros de Bases de Datos MDB, MDE" & Chr$(0) & "*.Mde;*.Mdb;" & Chr$(0)
Title$ = "Seleccionar Fichero Vincula.MDB de datos..." & Chr$(0)
DefExt$ = "MDB" & Chr$(0)
szCurDir$ = Ruta
OPENFILENAME.lStructSize = Len(OPENFILENAME)
OPENFILENAME.hwndOwner = Screen.ActiveForm.hwnd
OPENFILENAME.lpstrFilter = Filter$
OPENFILENAME.nFilterIndex = 1
OPENFILENAME.lpstrFile = FileName$
OPENFILENAME.nMaxFile = Len(FileName$)
OPENFILENAME.lpstrFileTitle = FileTitle$
OPENFILENAME.nMaxFileTitle = Len(FileTitle$)
OPENFILENAME.lpstrTitle = Title$
OPENFILENAME.flags = OFN_FILEMUSTEXIST Or OFN_READONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
OPENFILENAME.lpstrDefExt = DefExt$
OPENFILENAME.hInstance = 0
OPENFILENAME.lpstrCustomFilter = String(255, 0)
OPENFILENAME.nMaxCustFilter = 255
OPENFILENAME.lpstrInitialDir = szCurDir$
OPENFILENAME.nFileOffset = 0
OPENFILENAME.nFileExtension = 0
OPENFILENAME.lCustData = 0
OPENFILENAME.lpfnHook = 0
OPENFILENAME.lpTemplateName = 0
If apiGetOpenFileName(OPENFILENAME) <> 0 Then
OpenCommDlg = Left$(OPENFILENAME.lpstrFile, InStr(OPENFILENAME.lpstrFile, Chr$(0)) - 1)
Else
OpenCommDlg = ""
End If
Exit_TodoError:
Exit Function
Err_TodoError:
MsgBox "Aviso Nº: " & Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "PROGRAMA EJEMPLO"
Resume Exit_TodoError
End Function
(
geocities.com/es/ensolva/Descargas) (
geocities.com/es/ensolva) (
geocities.com/es)