Predmet:Re: Compact and Repair database iz koda
Evo kod mene compact back end baze:
PreuzmiIzvorni kôd (Text):Dim fa As Integer
Dim errloop
Dim F As Integer
Dim fileCompact As String
Dim disk As String
disk = Left(CurDir(), 2) ' odseca prva dva karaktera od putanje zbog promenljivosti diska.
fileCompact = disk & "\IH\Moja_Baza.mdb" ' apsolutna putanja
'fileCompact = disk & DLookup("[PUTANJA]", "Table1", "[SIFRAKOR]=" & var_sifrakor) ' relativna putanja
F = FreeFile
Open fileCompact For Binary Shared As #F
SizeBefore = LOF(F)
Close F
If MsgBox("Zelite li kompresiju podataka?", vbQuestion + vbYesNo, "Potvrda kompresije") = vbYes Then
On Error GoTo Err_Compact
DoCmd.Hourglass True
If FileExists(Mid(fileCompact, 1, Len(fileCompact) - 3) & "bak") Then
Kill Mid(fileCompact, 1, Len(fileCompact) - 3) & "bak"
End If
Name fileCompact As Mid(fileCompact, 1, Len(fileCompact) - 3) & "bak"
DBEngine.CompactDatabase Mid(fileCompact, 1, Len(fileCompact) - 3) & "bak", fileCompact
DoCmd.Hourglass False
MsgBox "Kompresija je izvršena!", vbInformation, "Obavijest"
F = FreeFile
Open fileCompact For Binary Shared As #F
SizeAfter = LOF(F)
Close F
PercentCompaction = (SizeBefore - SizeAfter) / SizeBefore
End If
Exit Sub
Err_Compact:
For Each errloop In DBEngine.Errors
MsgBox "Compaction unsuccessful!" & vbCr & _
"Error number: " & errloop.Number & _
vbCr & errloop.Description
Next errloop
Done:
End Sub
Function FileExists(strFile As String) As Boolean
Dim I As Integer
On Error Resume Next
I = Len(Dir(strFile))
FileExists = (Not Err And I > 0)
End Function
Miro