Sitios donde hayar codigo especifico para estos usos.
Utilidad que compacta ( Cierra la base y la compacta )
Public Function saldeunamalditavez()
'It only works when launched from a form rather than a module as {F10} calls up the toolbar (the same as pressing the ALT key) and 'TDC is Tools, Database utilites, Compact database.
'Whereas in a module the compact database option is not part of the toolbar.
SendKeys "%(TDC)", False
End Function
Utilidad que sirve para seleccionar un dir, recorrerlo en toda su profundidad y reparar-compactar todas aquellas bases mdb que no hayan sido compactadas y reparadas.
* deberas de tener marcadas las siguientes referencias:
scrrun.dll y msjro.dll
Llama al procedimiento desde un form de la siguiente manera y con los siguientes objetos.
Private Sub cmdCompactarReparar_Click
Direccion2 = BrowseFolder("Escoja la direccion de Destino")
End Sub
Private Sub cmdCompRepar_Click()
If IsNull(Direccion2) Then Exit Sub
CompactAllDirectory IIf(Left(Direccion2, 1) <> "\", Direccion2 & "\", Direccion2), Label1
Label1.Caption = "Completado"
End Sub
en un modulo escribe:
Option Base 0
Option Explicit
Dim index As Long
Dim innerIndex As Long
Dim compactedDBs() As String
Dim compacted As Boolean
Sub CompactAndRepairDB(dbfile As String)
Dim jetEngine As JRO.jetEngine
Dim strSourceConnect As String
Dim strDestConnect As String
Set jetEngine = New JRO.jetEngine
strSourceConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbfile & ";"
strDestConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbfile & ".ylk" & ";"
jetEngine.CompactDatabase strSourceConnect, strDestConnect
eliminabasevieja (dbfile)
Name dbfile & ".ylk" As dbfile
Set jetEngine = Nothing
End Sub
Sub eliminabasevieja(dbfile As String)
Kill dbfile
End Sub
Sub CompactAllDirectory(MyPath As String, lbl As Label)
Dim MyFile As String, MyName As String
Dim change As Boolean
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
MyFile = MyPath & MyName & "\"
If index <> 0 Then
innerIndex = 0
compacted = False
Do While innerIndex < index
If compactedDBs(innerIndex) = MyFile Then
compacted = True
Exit Do
End If
innerIndex = innerIndex + 1
Loop
End If
If Not compacted Then
CompactAllDirectory MyFile, lbl
change = True
ReDim Preserve compactedDBs(index)
compactedDBs(index) = MyFile
index = index + 1
End If
End If
End If
If change Then
MyName = Dir(MyPath, vbDirectory)
change = False
Else
MyName = Dir
End If
lbl.Caption = "Passing :" & MyPath & MyName
DoEvents
Loop
compactFiles MyPath, lbl
End Sub
Sub compactFiles(MyPath As String, lbl As Label)
Dim MyFile As String, MyName As String
MyName = Dir(MyPath & "*.mdb")
Do While MyName <> ""
MyFile = MyPath & MyName
If index <> 0 Then
innerIndex = 0
compacted = False
Do While innerIndex < index
If compactedDBs(innerIndex) = MyFile Then
compacted = True
Exit Do
End If
innerIndex = innerIndex + 1
Loop
End If
If Not compacted Then
lbl.Caption = "compactado :" & MyFile
If MyName = CurrentProject.Name Then
Else
If Form_z_GestionAdministrador.txtFin.Value = "Si" Then lbl.Caption = " Finalizado subitamente por el operador": Exit Sub
CompactAndRepairDB MyFile
ReDim Preserve compactedDBs(index)
compactedDBs(index) = MyFile
index = index + 1
End If
End If
MyName = Dir ' Get next entry.
DoEvents
Loop
End Sub
*** !!! Ojo : codigo semiadaptado de otro autor que lo ofrecia libre y a quien desconozco.
* Optimizada para access 2003