Home‎ > ‎

Re-Vincular las bases de datos Back-End y Front-End

Option Compare Database
Option Explicit
Private Declare Function SearchTreeForFile Lib _
                             "imagehlp" _
                             (ByVal RootPath As String, _
                              ByVal InputPathName As String, _
                              ByVal OutputPathBuffer As String) As Long
'***************************************************************
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&               Jefferson Jimenez (JJJT)                     &*
'&                 Cabimas - Venezuela                        &*
'&                    Agosto - 2009                           &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'***************************************************************
'Casi todo el codigo fue extraido de los foros de Access
'Declaraciones al API de Windows para la Busqueda
Function RutaCarpeta() As String
'Con esta funcion extraigo la ruta de la carpeta donde esta la Vinculacion
On Error GoTo RutaCarpeta_Error_Click
      Dim ObjetoTabla As DAO.TableDef
      Dim R1, R2 As String
      For Each ObjetoTabla In CurrentDb.TableDefs
        If Len(ObjetoTabla.Connect) > 0 Then
         R1 = ObjetoTabla.Connect
         R2 = Mid(R1, InStrRev(R1, "=") + 1)
         RutaCarpeta = Left(R2, InStrRev(R2, "\") - 1)
         Exit Function
        End If
      Next ObjetoTabla
      RutaCarpeta = ""
Exit_RutaCarpeta:
 Exit Function
RutaCarpeta_Error_Click:
 MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, NombreBD & ": Error de Datos"
 Resume Exit_RutaCarpeta
End Function
Function BDVinculada() As String
'En esta funcion le obligo siempre a Vincularse (asi se haya cambiado _
 el nombre de la Base de Datos del Front-End e incluso la Carpeta Origen)
On Error GoTo BDVinculada_Error_Click
      Dim ObjetoTabla As DAO.TableDef
      Dim Ruta As String
      For Each ObjetoTabla In CurrentDb.TableDefs
        If Len(ObjetoTabla.Connect) > 0 Then
         Ruta = ObjetoTabla.Connect
         BDVinculada = Mid(Ruta, InStrRev(Ruta, "\") + 1)
         Exit Function
        End If
      Next ObjetoTabla
      BDVinculada = ""
Exit_BDVinculada:
 Exit Function
BDVinculada_Error_Click:
 MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, NombreBD & ": Error de Datos"
 Resume Exit_BDVinculada
End Function
Function VinculaTablas(RutaFichero As String)
On Error GoTo VinculaTablas_Error_Click
'Aca le indico que debe re-vincularse con la BD Back-End con la cual Vinculamos desde el Origen
    Dim I As Integer
    Dim Dbs As DAO.Database
    Set Dbs = CurrentDb
    For I = 0 To Dbs.TableDefs.Count - 1
        If (Dbs.TableDefs(I).Connect <> "") Then
          Dbs.TableDefs(I).Connect = ";DATABASE=" & RutaFichero & ";"
         Dbs.TableDefs(I).RefreshLink
        End If
    Next I
    Dbs.Close
    BarraEstado
Exit_VinculaTablas:
 Exit Function
VinculaTablas_Error_Click:
 MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, NombreBD & ": Error de Datos"
 DoCmd.Close acForm, "Re-Vincula"
 Exit Function
 Resume Exit_VinculaTablas
End Function
Sub BarraEstado()
Const cVelocidad As Long = 2 * 8 ^ 4
Dim cTitulo As String
cTitulo = Etiqueta
Dim lngInteracciones As Long   '<< Maximo
Dim lngTemp As Long
Dim dtmTiempoStart As Date
Dim dtmTiempoFinnish As Date
Dim varResultado As Variant
      Application.SetOption "Show Status Bar", True
      DoCmd.Hourglass True
      dtmTiempoStart = Now
      lngInteracciones = cVelocidad
      varResultado = SysCmd(acSysCmdInitMeter, cTitulo, lngInteracciones)
      Do Until lngTemp > lngInteracciones
            DoEvents
            varResultado = SysCmd(acSysCmdUpdateMeter, lngTemp)
            lngTemp = lngTemp + 1
      Loop
      SysCmd acSysCmdSetStatus, "Fin,..."
      dtmTiempoFinnish = Now
      DoCmd.Hourglass False
      MsgBox "Operación finalizada exitosamente.", vbInformation, NombreBD & ": Re-Vincular"
      varResultado = SysCmd(acSysCmdRemoveMeter)
Proc_Exit:
      Exit Sub
End Sub
Function Etiqueta() As String
'Le creo una etiqueta que me sirva de adorno a la re-vinculacion
Dim accObj As AccessObject
Dim strEstatus As String
Dim intX As Integer
Dim lngTablas As Long
Dim intY As Integer
        DoEvents
      intY = 0
      lngTablas = Application.CurrentData.AllTables.Count
      For Each accObj In Application.CurrentData.AllTables
      intY = intY + 1
            Etiqueta = " * * * * * Por favor espera...                                                              " & _
            NombreBD & ": ESTA REVINCULANDO TODAS LAS TABLAS NUEVAMENTE . . .  " & intY & " de " & lngTablas & " "
            DoEvents
            If Not (accObj.Attributes And dbSystemObject) And Not Left(accObj.Name, 4) = "MSys" Then
            intX = intX + 1
            End If
      Next accObj
      DoEvents
      Set accObj = Nothing
End Function
Function Vinculacion_Rota()
'Por aqui lanzo la pregunta y le indico opciones
Dim Pregunta As String
If Dir(RutaCarpeta & "\" & BDVinculada) = "" Then
    Pregunta = MsgBox("Hemos detectado Errores al Vincular" & vbCrLf & _
    "y se ha roto la conexion con los datos de origen" & vbCrLf & _
    "indique si desea Revincular...?", vbInformation + vbYesNo, NombreBD & ": Vincular")
    If Pregunta = 6 Then
    Revincula
    End If
    If Pregunta = 7 Then
    MsgBox "Ud. Eligio no vincular" & vbCrLf & _
    "los datos que en ella se ingresen, no quedaran guardados" & vbCrLf & _
    "o bien tendra errores al abrir los Form", vbInformation, NombreBD & ": Desprotegida"
    End If
End If
End Function
Function BuscarArchivo() As String
'Busco en la PC la BDVinculada
Dim MiBd As String
Dim LaExt As String
LaExt = Right(BDVinculada, Len(BDVinculada) - InStrRev(BDVinculada, "."))
MiBd = Left(BDVinculada, Len(BDVinculada) - (Len(LaExt) + 1))
  If JJJTBuscarArchivo(LaExt, MiBd) <> "" Then
      MsgBox "Archivo encontrado en  " & JJJTBuscarArchivo(LaExt, MiBd), vbInformation, NombreBD
      BuscarArchivo = JJJTBuscarArchivo(LaExt, MiBd)
   Else
      MsgBox "La Base Datos : " & BDVinculada & vbCrLf & _
      "Seguro a cambiado de nombre" & vbCrLf & vbCrLf & _
      "Es Necesario que la Ubique Ud Mismo", vbExclamation, NombreBD & ": Cambio Nombre"
      JJJT_CuadroDialog "Access" + Chr$(0) + "*.mdb;*.accdb", "C:\"
      BuscarArchivo = Var
   End If
      DoCmd.Hourglass False
End Function
Function Revincula()
'Por aqui llamo a revincular
 Dim prg As String
     prg = MsgBox("Le pregunto...?" & vbCrLf & _
        "Desea Ud. que el programa " & vbCrLf & _
           "busque la Bd : " & BDVinculada & vbCrLf & _
            "De forma automatica....?" & vbCrLf & vbCrLf & _
            "De Elegir 'Si'" & vbCrLf & vbCrLf & _
            "El proceso podria tardar un poco," & vbCrLf & _
            "se buscara en todas las unidades" & vbCrLf & _
            "disponibles de esta PC", vbInformation + vbYesNo, NombreBD & ": Revincula")
         If prg = vbYes Then
       VinculaTablas BuscarArchivo
      End If
       If prg = vbNo Then
         JJJT_CuadroDialog "Access" + Chr$(0) + "*.mdb;*.accdb", "C:\"
           VinculaTablas Var
       End If
End Function
Function VincularTabla()
'Por aqui vinculo una sola tabla que se cree posteriormente
   On Error GoTo VincularTabla_Error_Click
      Dim LaTabla As String
          LaTabla = InputBox("Indique el nombre de la tabla que ha creado previamente en la " & _
            "base de datos: " & BDVinculada, NombreBD)
            DoCmd.TransferDatabase acLink, "Microsoft Access", _
            RutaCarpeta & "\" & BDVinculada, acTable, _
            LaTabla, LaTabla, False
        MsgBox "Vinculada exitosamente la Tabla: " & LaTabla & " desde la Base " & vbCrLf & _
     "de datos: " & RutaCarpeta & "\" & BDVinculada & " En esta otra Base " & vbCrLf & _
  "de datos: " & CurrentProject.Name, vbInformation, NombreBD
Exit_VincularTabla:
             Exit Function
VincularTabla_Error_Click:
             MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, NombreBD & ": Error de Datos"
              Exit Function
             Resume Exit_VincularTabla
End Function
'***************************************************************
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&               Jefferson Jimenez (JJJT)                     &*
'&                 Cabimas - Venezuela                        &*
'&                    Abril - 2010                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'***************************************************************
Function JJJTBuscarArchivo(ExtArch As String, NomArch As String) As String
On Error Resume Next
Dim fso As Object
Dim drv As Object
Dim strRuta As String
Dim MiUnd As String
DoCmd.Hourglass True
   strRuta = String(260, vbNullChar)
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each drv In fso.Drives
      MiUnd = drv.DriveLetter & ":\"
       If SearchTreeForFile(MiUnd, NomArch & "." & ExtArch, strRuta) Then
          JJJTBuscarArchivo = Left$(strRuta, InStr(strRuta, vbNullChar) - 1)
       End If
   Next
 Set fso = Nothing
DoCmd.Hourglass False
End Function
 

SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ

Descargar
Descargue El Ejemplo  112 kb v. 21 7 may. 2010 11:39 Jefferson Jimenez
Comments