| Respuesta: Como crear un Back up y como restaurar ese back up
El formulario principal consta de 2 botones (CmdCopiaseguridad y CmdRecuperar) y de un CommonDialog (DlgArchivos) y PictureBox (Mensaje), en mi caso.
Los dirección de la base respaldada se guardan en el archivo config.ini el cual se crea cuando se inicia la aplicación. Hay que crear un Modulo Bas, mas abajo esta el código
La base de datos debe de estar cerrada de lo contrario da error
//// Form
Dim DirAnterior As String
Dim NomArchivoSeg As String
Dim FActual As String
Const TITULO = "BACKUP" 'el titulo de la ventana y de los msgbox
Private Sub CmdCopiaseguridad_Click()
CompactarBD
If DirAnterior <> "" Then
DlgArchivos.InitDir = DirAnterior
Else
DlgArchivos.InitDir = DameDirectorioAplicacion
End If
DlgArchivos.FileName = FActual
On Error GoTo ManipularErrorGuardar
DlgArchivos.CancelError = True
DlgArchivos.Filter = "Ficheros de proyecto (*.bak)|*.bak|Todos los ficheros (*.*)|*.*"
DlgArchivos.FilterIndex = 1
DlgArchivos.ShowSave
Label14.Caption = "Copiando copia de seguridad"
DoEvents
SHCopyFile App.Path & "\bd.mdb", DlgArchivos.FileName
Dim Indice As Long
For Indice1 = Len(DlgArchivos.FileName) To 1 Step -1
If Mid$(DlgArchivos.FileName, Indice1, 1) = "\" Then Exit For
Next
NomArchivoSeg = Mid$(DlgArchivos.FileName, Indice1 + 1, Len(DlgArchivos.FileName))
DirAnterior = Mid$(DlgArchivos.FileName, 1, (Len(DlgArchivos.FileName) - Len(NomArchivoSeg)) - 1)
SalirGuardar:
Mensaje.Visible = False
MsgBox "Finished backup", vbInformation, TITULO
Screen.MousePointer = 0
Exit Sub
ManipularErrorGuardar:
Screen.MousePointer = 0
Mensaje.Visible = False
If Err.Number = cdlCancel Then Exit Sub
MsgBox Err.Description
Resume SalirGuardar
End Sub
Private Function CompactarBD()
Screen.MousePointer = 11
On Error Resume Next
Dim BaseDeDatos As String
Dim BaseDeDatosCo As String
BaseDeDatos = App.Path & "\bd.mdb" 'la direccion de la base de datos original
BaseDeDatosCo = Mid$(BaseDeDatos, 1, Len(BaseDeDatos) - 4) & "Co.mdb" 'la direccion que tendra la copia
If Dir(DameDirectorioAplicacion & "~bdatos.mdb") Then _
Kill DameDirectorioAplicacion & "~bdatos.mdb"
Mensaje.Visible = True
Label14.Caption = "Copia de seguridad en progreso"
DoEvents
FileCopy BaseDeDatos, DameDirectorioAplicacion & "~bdatos.mdb"
If Dir(BaseDeDatosCo) <> "" Then _
Kill BaseDeDatosCo
Label14.Caption = "Compactando base de datos"
DoEvents
DBEngine.CompactDatabase BaseDeDatos, _
BaseDeDatosCo, dbLangGeneral
'si nuestra bd tiene contraseña se haría con esta instrucción:
' DBEngine.CompactDatabase BaseDeDatos, _
' BaseDeDatosCo, dbLangSpanish & ";pwd =" & gClave, , ";pwd =" & gClave
'si tiene contraseña, hay que añadir ,pwd="contraseña"
If Dir(BaseDeDatosCo) <> "" Then
Kill BaseDeDatos
End If
Label14.Caption = "Restaurando base de datos"
DoEvents
FileCopy BaseDeDatosCo, BaseDeDatos
Kill BaseDeDatosCo
Kill DameDirectorioAplicacion & "~bdatos.mdb"
Screen.MousePointer = 0
Label14.Caption = "Base de datos compactada"
DoEvents
End Function
Private Sub CmdRecuperar_Click()
DlgArchivos.CancelError = True
On Error Resume Next
DlgArchivos.FileName = NomArchivoSeg
DlgArchivos.InitDir = DirAnterior
DlgArchivos.Filter = "Backup (*.bak)|*.bak|" & "all files (*.*)|*.*"
DlgArchivos.Action = 1
If Err.Number = 0 Then
On Error Resume Next
If MsgBox("La base de datos será reemplazada, ¿Estas seguro?", vbQuestion + vbYesNo, TITULO) <> vbYes Then Exit Sub
Screen.MousePointer = 11
On Error Resume Next
FileCopy DlgArchivos.FileName, App.Path & "\bd.mdb"
If Err.Number <> 0 Then
MsgBox "Error recuperando la base de datos", vbCritical, TITULO
Else
MsgBox "Recuperacion de la base de datos completa", vbInformation, TITULO
End If
On Error GoTo 0
Screen.MousePointer = 0
Else
MsgBox "Restauración de la base de datos cancelada por el usuario", vbInformation, TITULO
End If
End Sub
Private Sub Form_Load()
Dim nPermiso As Integer
Me.Caption = TITULO
Screen.MousePointer = 0
FActual = Format(Now, "dd_mm_yyyy")
'comprobar si existe el archivo ini
If Not ExisteArchivo(DameDirectorioAplicacion & "config.ini") Then
DirAnterior = DameDirectorioAplicacion
'si no existe dar direccion por defecto (en este caso, la carpera del programa)
Else
DirAnterior = LeerIni(DameDirectorioAplicacion & "config.ini", "CopiaBD", "DirCopia")
NomArchivoSeg = LeerIni(DameDirectorioAplicacion & "config.ini", "CopiaBD", "NombreCopia")
If Trim$(DirAnterior) <> "" Then
DirAnterior = Mid(DirAnterior, 1, Len(Trim$(DirAnterior)) - 1)
Else
DirAnterior = DameDirectorioAplicacion
End If
If Trim$(NomArchivoSeg) <> "" Then
NomArchivoSeg = Mid(NomArchivoSeg, 1, Len(Trim$(NomArchivoSeg)) - 1)
End If
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
If DirAnterior <> "" Then
EscribirIni "CopiaBD", "DirCopia", DirAnterior, DameDirectorioAplicacion & "config.ini"
End If
If NomArchivoSeg <> "" Then
EscribirIni "CopiaBD", "NombreCopia", NomArchivoSeg, DameDirectorioAplicacion & "config.ini"
End If
End Sub
Function DameDirectorioAplicacion() As String
DameDirectorioAplicacion = UCase$(App.Path)
If Right(DameDirectorioAplicacion, 1) <> "\" Then DameDirectorioAplicacion = DameDirectorioAplicacion & "\"
End Function
//// El Modulo bas
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As _
String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As _
String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As _
Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Option Explicit
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_COPY = &H2
Private Const FOF_ALLOWUNDO = &H40
Public Function LeerIni(Archivo As String, Situacion As String, campo As String) As String
Dim i As Integer
Dim Est As String
Est = String$(150, " ")
i = GetPrivateProfileString(Situacion, campo, "", Est, Len(Est), Archivo)
If i > 0 Then LeerIni = Est
End Function
Public Function EscribirIni(Situacion As String, campo As String, Valor As String, Archivo As String)
Dim i As Integer
Dim Est As String
Est = Valor
i = WritePrivateProfileString(Situacion, campo, Est, Archivo)
End Function
Public Function ExisteArchivo(Nombre As String) As Boolean
Dim Cadena As String
Dim x As Long
On Error GoTo Fallo
If Nombre = "" Then
Exit Function
End If
Cadena = Nombre
x = GetAttr(Cadena)
ExisteArchivo = True
Exit Function
Fallo:
ExisteArchivo = False
End Function
Function DameDirectorioAplicacion() As String
DameDirectorioAplicacion = UCase$(App.Path)
If Right(DameDirectorioAplicacion, 1) <> "\" Then DameDirectorioAplicacion = DameDirectorioAplicacion & "\"
End Function
Public Sub SHCopyFile(ByVal from_file As String, ByVal to_file As String)
Dim sh_op As SHFILEOPSTRUCT
With sh_op
.hwnd = 0
.wFunc = FO_COPY
.pFrom = from_file & vbNullChar & vbNullChar
.pTo = to_file & vbNullChar & vbNullChar
.fFlags = FOF_ALLOWUNDO
End With
SHFileOperation sh_op
End Sub
////
Espero que sirva. Se que es un disparate de código pero es el de mejor resultado que tengo, ya que no solo respalda sino también compacta. Tal vez alguien sepa de uno mas simple y compacto.
Saludos Marcelo |