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