Option Compare Database
Option Explicit
Function funCompactarBDVinculadas()
On Error GoTo Err_Function_Compactar
Dim dbs As DAO.Database
Dim strDynamicArray() As String 'Nombre matriz
Dim strRutaOrigenDatos As String
Dim strPwdOrigenDatos As String
Dim strBDaCompactar As String
Dim intContador1 As Integer
Dim intContador2 As Integer
Dim strNombreBD As String
Dim strNombreBDCompactada As String
Dim strNombreBDTrabajo As String
Set dbs = CurrentDb()
For intContador1 = 0 To dbs.TableDefs.Count - 1
If left(dbs.TableDefs(intContador1).Name, 4) <> "MSys" Then
If (dbs.TableDefs(intContador1).Attributes And dbAttachedTable) Or (dbs.TableDefs(intContador1).Attributes And dbAttachedODBC) Then
If left(dbs.TableDefs(intContador1).Name, 4) <> "~TMP" Then
strBDaCompactar = dbs.TableDefs(intContador1).Name
strRutaOrigenDatos = dbs.TableDefs(strBDaCompactar).Connect
strBDaCompactar = Mid(strRutaOrigenDatos, InStrRev(strRutaOrigenDatos, "\") + 1)
ReDim Preserve strDynamicArray(intContador1)
strDynamicArray(intContador1) = strBDaCompactar
For intContador2 = 0 To intContador1 - 1
If strDynamicArray(intContador2) = strBDaCompactar Then
GoTo Continua_Local_Function:
End If
Next intContador2
Forms!frmCompactar!ctrlListBox.Value = strBDaCompactar
Rem El numero 10 sale porque ";DATABASE=" tiene 10 caracteres
Rem codigo anadido por: Juan Menendez/Mastercafe (BBDD ahora con Password)
If left(strRutaOrigenDatos, 10) = ";DATABASE=" Then 'no tiene password
strRutaOrigenDatos = Mid(strRutaOrigenDatos, 11, Len(strRutaOrigenDatos))
strRutaOrigenDatos = left(strRutaOrigenDatos, Len(strRutaOrigenDatos) - Len(strBDaCompactar))
strPwdOrigenDatos = ""
Else
strPwdOrigenDatos = Mid(strRutaOrigenDatos, InStr(1, strRutaOrigenDatos, ";PWD=Contraseñasilatiene") + 5, InStr(1, strRutaOrigenDatos, ";database=") - (InStr(1, strRutaOrigenDatos, ";PWD=") + 5))
strRutaOrigenDatos = Mid(strRutaOrigenDatos, InStr(1, strRutaOrigenDatos, ";database=") + 10, Len(strRutaOrigenDatos))
strRutaOrigenDatos = left(strRutaOrigenDatos, Len(strRutaOrigenDatos) - Len(strBDaCompactar))
End If
If Len(Dir(strRutaOrigenDatos & strBDaCompactar)) = 0 Then
Beep
MsgBox "ERROR al Compactar: " & vbCr & vbCrLf & _
"En el directorio, no existe el Back-End", vbCritical, "Error N.: " & err.Number
GoTo Exit_Function_Compactar
End If
strNombreBD = strRutaOrigenDatos & strBDaCompactar
strNombreBDCompactada = strRutaOrigenDatos & "C_" & strBDaCompactar
strNombreBDTrabajo = strRutaOrigenDatos & "T_" & strBDaCompactar
If Len(Dir(strNombreBDCompactada)) > 0 Then
Kill strNombreBDCompactada
End If
If strPwdOrigenDatos <> "" Then
DBEngine.CompactDatabase strNombreBD, strNombreBDCompactada, ";pwd=" & strPwdOrigenDatos, , ";pwd=" & strPwdOrigenDatos
Else
DBEngine.CompactDatabase strNombreBD, strNombreBDCompactada
End If
If Len(Dir(strNombreBDTrabajo)) > 0 Then
Kill strNombreBDTrabajo
End If
Name strNombreBD As strNombreBDTrabajo
Name strNombreBDCompactada As strNombreBD
Kill strNombreBDTrabajo
End If
End If
End If
Next intContador1
Continua_Local_Function:
Erase strDynamicArray
dbs.Close
Set dbs = Nothing
If Len(strBDaCompactar) = 0 Then
MsgBox "No ha sido posible Compactar" & vbCrLf & _
"Es posible que no tengas ninguna Tabla Vinculada en esta Base de Datos.", vbExclamation, "No existe BD"
If MsgBox("Quieres abrir el asistente de las tablasvinculadas?", vbInformation + vbYesNo, "Asistente") = vbYes Then DoCmd.OpenForm "FrmVincula" 'Nombre del formulario de vinculación del back-end
MsgBox "Solo se han vinculado las tablas pero no se ha hecho ninguna Compactacion." & vbCrLf & _
"Ahora deberias volver a compactar.", vbInformation, "Aviso"
End If
GoTo Exit_Function_Compactar
End If
DoCmd.Hourglass False
Exit_Function_Compactar:
Exit Function
Err_Function_Compactar:
Select Case err.Number
Case 2501
Rem No hacer nada. Aparece este error cuando se cancela el DialogBox
Case Else
Rem error no previsto
MsgBox err.Description, vbCritical, "Error Function N.: " & err.Number
End Select
Resume Exit_Function_Compactar:
End Function
Crear cuenta
