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 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

DoCmd.Hourglass False

End Function