Dairy Farmer
Registered User.
- Local time
- Today, 06:00
- Joined
- Sep 23, 2010
- Messages
- 244
Sorry I took the code out and made it a Module a while back. the code I gave was from an updates form.
The code goes in On Open.
Make the form as above. Then create a Module and use the following code:
The code goes in On Open.
Make the form as above. Then create a Module and use the following code:
Code:
Option Compare Database
Option Explicit
Function Restore()
Dim str As String
Dim buf As String
Dim MD_Date As Variant
Dim fs As Object
Dim source As String
Dim pubInputFolder As String
Dim txtfolder As String
Dim deletesource As String
Const conPATH_FILE_ACCESS_ERROR = 75
On Error GoTo 0
With Application.FileDialog(4)
.InitialFileName = CurrentProject.Path & "\Backups\"
.AllowMultiSelect = False
.Filters.Clear
.Show
pubInputFolder = .SelectedItems(1)
txtfolder = pubInputFolder
End With
On Error GoTo Backup
buf = CurrentProject.Path & "\Backups\"
MkDir buf
Resume Backup
Backup:
MD_Date = Format(Date, "yyyy-mm-dd ") & Format(Time, "hh-mm-ss") & " R"
str = CurrentProject.Path & "\Backups\" & MD_Date
source = CurrentProject.Path & "\Data\"
MkDir str
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile source & "*.accdb", str
Set fs = Nothing
deletesource = CurrentProject.Path & "\Data\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile deletesource & "\*.accdb"
Set fs = Nothing
Dim backupsource As String
Dim destination As String
backupsource = txtfolder
destination = CurrentProject.Path & "\Data\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile backupsource & "\*.*", destination & "\"
Set fs = Nothing
MsgBox "Data from " & vbNewLine & backupsource & vbNewLine & _
"successfully restored!", vbInformation, "Restore Successful"
DoCmd.Close acForm, "F_0_Restore"
ExitBackup:
DoCmd.OpenForm "_Splash1", acNormal, "", "", , acNormal
Exit Function
ErrBackup:
If Err.Number = conPATH_FILE_ACCESS_ERROR Then
MsgBox "The following Path, " & str & ", already exists or there was an Error " & _
"accessing it!", vbExclamation, "Path/File Access Error"
Else
MsgBox Err.Description, vbExclamation, "Error Creating " & str
Resume ExitBackup
End If
End Function
Attachments
Last edited: