merhaba sitede bir çok örnek var yedekleme ve bakım ile ilgili ama benim yapmak istediğim forma koyduğum bir butonla ikisini aynı anda yaptırmak. yani butona tıkladığımda önce onarıcak ve ardından datebasenin olduğu yere yedek alıcak. kendi programımda kullandığım kodlar aşağıdadır. yedek konusunda ise her yedek aldığımda önceki yedeğin üzerine yazıyor ve bu şekilde kalmadı bence çok daha iyi. ikisini tek kodda yapmak mümkünmüdür.
Private Sub Resim287_DblClick(Cancel As Integer)
Dim msg As String
DoCmd.SelectObject acForm, "frmSearch", True
msg = "Lütfen Dikkat, veritabanında girdiğiniz kayıtlar tutulmaktadır. "
msg = msg & "Girdiğiniz ve/veya sildiğiniz kayıtlarla bu dosya zamanla gereksiz yere şişer."
msg = msg & "Bunun için [Veritabanı dosyası bakımı] işlemini en geç 7 günde bir yaparsanız, "
msg = msg & "gereksiz şişkinlikler dosyanızdan atılacak, dolayısıyla dosyanızın boyutu küçülecektir." & vbCrLf & vbCrLf
msg = msg & "Özellikle hafta sonları yedeklemelerden önce" & vbCrLf
msg = msg & "[Veritabanı dosyası bakımı] işlemini uygulamanız tavsiye edilir." & vbCrLf & vbCrLf
msg = msg & "Evet'i Seçerseniz...Programın Düzenlenip Onarılabilmesi için Kapatılması Gerekiyor " & vbCrLf & vbCrLf
msg = msg & "Şimdi veritabanı dosyanızın bakımını yapacak mısınız?" & vbCrLf & vbCrLf
If MsgBox(msg, vbQuestion + vbYesNo, "Veritabanı dosyası bakımı") = vbNo Then Exit Sub
'hayır denilirse ana menüye geri dönülüyor
Call DuzenleOnarYenile
End Sub
Public Function DuzenleOnarYenile()
Dim scriptpath As String
scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat"
If Dir(scriptpath, vbNormal) <> "" Then
If DateAdd("s", TIMEOUT * 2, FileDateTime(scriptpath)) < Date Then
Kill scriptpath
Else
Application.Quit acQuitSaveAll
Exit Function
End If
End If
Dim s As String
s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf
s = s & "SET /a counter=0" & vbCrLf
s = s & ":CHECKLOCKFILE" & vbCrLf
s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf
s = s & "SET /a counter+=1" & vbCrLf
s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf
s = s & "IF EXIST ""%~f2.%4"" GOTO CHECKLOCKFILE" & vbCrLf
s = s & """%~f1"" ""%~f2.%3"" /compact" & vbCrLf
s = s & "start "" "" ""%~f2.%3""" & vbCrLf
s = s & ":CLEANUP" & vbCrLf
s = s & "del %0"
Dim intFile As Integer
intFile = FreeFile()
Open scriptpath For Output As #intFile
Print #intFile, s
Close #intFile
Dim dbname As String, ext As String, lockext As String, accesspath As String
Dim idx As Integer
accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
For idx = Len(CurrentProject.FullName) To 1 Step -1
If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For
Next idx
dbname = Left(CurrentProject.FullName, idx - 1)
ext = Mid(CurrentProject.FullName, idx + 1)
If Left(ext, 2) = "ac" Then
lockext = "laccdb"
Else
lockext = "ldb"
End If
s = """" & scriptpath & """ """ & accesspath & """ """ & dbname & """ " & ext & " " & lockext
Shell s, vbHide
Application.Quit acQuitSaveAll
End Function
[/code]
Private Sub kapa_Click()
If MsgBox("KeSoKa Expert Revir programı kapatıp yedek alınsın mı ?", vbCritical + vbOKCancel) = vbOK Then
On Error Resume Next
Dim CurDB As String, KopiaDB As String, LenDB As Long, Plik As String, NrPliku As Long
DoCmd.Hourglass -1
CurDB = CurrentDb.Name
Err = 0
Plik = Space(FileLen(CurDB))
NrPliku = FreeFile
Open CurDB For Binary Access Read Shared As #NrPliku
Get #NrPliku, 1, Plik
Close #NrPliku
If Err = 52 Then
MsgBox "Kopyalanamadı. " & CurDB & "Kopyalama işlemi başarısız.", 48, "Kopyalanıyor."
ElseIf Err Then
MsgBox Err.Description
Else
KopiaDB = InputBox("Program yedeklenecek, Kayıt yeri aşağıdaki gibi:" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Programın kaydedileceği yer:.", "KeSoKa---> Değiştirmeden onaylayınız.", Left(CurDB, Len(CurDB) - Len(Dir(CurDB))) & "Revir yedek.mdb")
If KopiaDB & "" <> "" Then
Kill KopiaDB
Err = 0
NrPliku = FreeFile
Open KopiaDB For Binary Access Write Shared As #NrPliku
Put #NrPliku, 1, Plik
Close #NrPliku
If Err = 0 Then
MsgBox "Yedek Dosyanız Alınmıştır."
Else
MsgBox Err.Description
End If
End If
End If
DoCmd.Hourglass 0
DoCmd.Close
DoCmd.OpenForm "KAPANIS"
Else
Me.Undo
MsgBox "işlemi iptal ettniz. Program çalışmaya devam ediyor."
End If
End Sub
onarma kodu:
Private Sub Resim287_DblClick(Cancel As Integer)
Dim msg As String
DoCmd.SelectObject acForm, "frmSearch", True
msg = "Lütfen Dikkat, veritabanında girdiğiniz kayıtlar tutulmaktadır. "
msg = msg & "Girdiğiniz ve/veya sildiğiniz kayıtlarla bu dosya zamanla gereksiz yere şişer."
msg = msg & "Bunun için [Veritabanı dosyası bakımı] işlemini en geç 7 günde bir yaparsanız, "
msg = msg & "gereksiz şişkinlikler dosyanızdan atılacak, dolayısıyla dosyanızın boyutu küçülecektir." & vbCrLf & vbCrLf
msg = msg & "Özellikle hafta sonları yedeklemelerden önce" & vbCrLf
msg = msg & "[Veritabanı dosyası bakımı] işlemini uygulamanız tavsiye edilir." & vbCrLf & vbCrLf
msg = msg & "Evet'i Seçerseniz...Programın Düzenlenip Onarılabilmesi için Kapatılması Gerekiyor " & vbCrLf & vbCrLf
msg = msg & "Şimdi veritabanı dosyanızın bakımını yapacak mısınız?" & vbCrLf & vbCrLf
If MsgBox(msg, vbQuestion + vbYesNo, "Veritabanı dosyası bakımı") = vbNo Then Exit Sub
'hayır denilirse ana menüye geri dönülüyor
Call DuzenleOnarYenile
End Sub
onarma modülü kodları:
Public Function DuzenleOnarYenile()
Dim scriptpath As String
scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat"
If Dir(scriptpath, vbNormal) <> "" Then
If DateAdd("s", TIMEOUT * 2, FileDateTime(scriptpath)) < Date Then
Kill scriptpath
Else
Application.Quit acQuitSaveAll
Exit Function
End If
End If
Dim s As String
s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf
s = s & "SET /a counter=0" & vbCrLf
s = s & ":CHECKLOCKFILE" & vbCrLf
s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf
s = s & "SET /a counter+=1" & vbCrLf
s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf
s = s & "IF EXIST ""%~f2.%4"" GOTO CHECKLOCKFILE" & vbCrLf
s = s & """%~f1"" ""%~f2.%3"" /compact" & vbCrLf
s = s & "start "" "" ""%~f2.%3""" & vbCrLf
s = s & ":CLEANUP" & vbCrLf
s = s & "del %0"
Dim intFile As Integer
intFile = FreeFile()
Open scriptpath For Output As #intFile
Print #intFile, s
Close #intFile
Dim dbname As String, ext As String, lockext As String, accesspath As String
Dim idx As Integer
accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
For idx = Len(CurrentProject.FullName) To 1 Step -1
If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For
Next idx
dbname = Left(CurrentProject.FullName, idx - 1)
ext = Mid(CurrentProject.FullName, idx + 1)
If Left(ext, 2) = "ac" Then
lockext = "laccdb"
Else
lockext = "ldb"
End If
s = """" & scriptpath & """ """ & accesspath & """ """ & dbname & """ " & ext & " " & lockext
Shell s, vbHide
Application.Quit acQuitSaveAll
End Function
[/code]
yedek al ve kapa kodu:
Private Sub kapa_Click()
If MsgBox("KeSoKa Expert Revir programı kapatıp yedek alınsın mı ?", vbCritical + vbOKCancel) = vbOK Then
On Error Resume Next
Dim CurDB As String, KopiaDB As String, LenDB As Long, Plik As String, NrPliku As Long
DoCmd.Hourglass -1
CurDB = CurrentDb.Name
Err = 0
Plik = Space(FileLen(CurDB))
NrPliku = FreeFile
Open CurDB For Binary Access Read Shared As #NrPliku
Get #NrPliku, 1, Plik
Close #NrPliku
If Err = 52 Then
MsgBox "Kopyalanamadı. " & CurDB & "Kopyalama işlemi başarısız.", 48, "Kopyalanıyor."
ElseIf Err Then
MsgBox Err.Description
Else
KopiaDB = InputBox("Program yedeklenecek, Kayıt yeri aşağıdaki gibi:" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Programın kaydedileceği yer:.", "KeSoKa---> Değiştirmeden onaylayınız.", Left(CurDB, Len(CurDB) - Len(Dir(CurDB))) & "Revir yedek.mdb")
If KopiaDB & "" <> "" Then
Kill KopiaDB
Err = 0
NrPliku = FreeFile
Open KopiaDB For Binary Access Write Shared As #NrPliku
Put #NrPliku, 1, Plik
Close #NrPliku
If Err = 0 Then
MsgBox "Yedek Dosyanız Alınmıştır."
Else
MsgBox Err.Description
End If
End If
End If
DoCmd.Hourglass 0
DoCmd.Close
DoCmd.OpenForm "KAPANIS"
Else
Me.Undo
MsgBox "işlemi iptal ettniz. Program çalışmaya devam ediyor."
End If
End Sub


Yazan okuyan sağolsun, çözene saygılar. Kolaylaştırınız, zorlaştırmayınız.
