'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