[Resolvido]Zipar Pasta do Aplicativo

Olá Pessoal,

Estou desenvolvendo um aplicativo e gostaria de fazer o backup do mesmo só que não do Arquivo Access (*.accbd) e sim da pasta do Sistema, vi muitos exemplos aqui no Fórum, mas a maioria é do arquivo e não do Ficheiro. Alguém tem um exemplo para compartilhar?

Cumprimentos!

Este tópico o ajudou? Agradecer não custa nada e ainda nos motiva a continuar lhe ajudando. Então que tal dar um joinha ?

Jeferson,

Algum tempo atrás tive esta mesma necessidade. Solução criei um utilitário de backup que fica fora do diretório do sistema e/ou aplicativo. no botão de comando sair do sistema e/ou aplicativo inseri um código que chama o utilitário de backup.


Abraços,

Olá amigo Uilson, realmente é muito difícil de se achar algo do gênero. Mas rodando na internet achei uma rotina mas não consegui usá-la, se puder dar uma olhadinha, ficarei grato!

Direitos de autor são importantes: http://www.rondebruin.nl/files/codewinzipzippage.txt

Código:

Declare Function OpenProcess Lib "kernel32" _
                           (ByVal dwDesiredAccess As Long, _
                            ByVal bInheritHandle As Long, _
                            ByVal dwProcessId As Long) As Long

Declare Function GetExitCodeProcess Lib "kernel32" _
                                  (ByVal hProcess As Long, _
                                   lpExitCode As Long) As Long

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
  Dim hProg As Long
  Dim hProcess As Long, ExitCode As Long
  'fill in the missing parameter and execute the program
  If IsMissing(WindowState) Then WindowState = 1
  hProg = Shell(PathName, WindowState)
  'hProg is a "process ID under Win32. To get the process handle:
  hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
  Do
      'populate Exitcode variable
      GetExitCodeProcess hProcess, ExitCode
      DoEvents
  Loop While ExitCode = STILL_ACTIVE
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
  On Error Resume Next
  bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function



'With this example you browse to the folder you want to zip
'The zip file will be saved in: DefPath = Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'You can change this folder to this if you want to use another folder
'DefPath = "C:\Users\Ron\ZipFolder"
'There is no need to change the code before you test it

Sub A_Zip_Folder_And_SubFolders_Browse_WinZip()
  Dim PathZipProgram As String, NameZipFile As String, FolderName As String
  Dim ShellStr As String, strDate As String, DefPath As String
  Dim Fld As Object, Password As String

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Create Path and name of the new zip file
  'The zip file will be saved in: DefPath = Application.DefaultFilePath
  'Normal if you have not change it this will be your Documents folder
  'You can change the folder if you want to another folder like this
  'DefPath = "C:\Users\Ron\ZipFolder"
  DefPath = Application.DefaultFilePath
  If Right(DefPath, 1) <> "\" Then
      DefPath = DefPath & "\"
  End If

  'Create date/Time string, also the name of the Zip in this example
  strDate = Format(Now, "yyyy-mm-dd hh-mm-ss")

  'Set NameZipFile to the full path/name of the Zip file
  'If you want to add the word "MyZip" before the date/time use
  'NameZipFile = DefPath & "MyZip " & strDate & ".zip"
  NameZipFile = DefPath & strDate & ".zip"

  'Browse to the folder with the files that you want to Zip
  Set Fld = CreateObject("Shell.Application").BrowseForFolder(0, "Select folder to Zip", 512)
  If Not Fld Is Nothing Then
      FolderName = Fld.Self.Path
      If Right(FolderName, 1) <> "\" Then
          FolderName = FolderName & "\"
      End If

      On Error Resume Next

      'Zip all the files in the folder and subfolders, -r is Include subfolders
      'If you add -p, WinZip will store folder information for all files added,
      'not just for files from subfolders; the folder information will begin with
      'the folder specified on the command line.
      ShellStr = PathZipProgram & "Winzip32.exe -min -a -r" _
               & " " & Chr(34) & NameZipFile & Chr(34) _
               & " " & Chr(34) & FolderName & "*.*" & Chr(34)


      'Note: you can replace the ShellStr with one of the example ShellStrings
      'below to test one of the examples

      'Zip the txt files in the folder and subfolders, use "*.xl*" for all excel files
      '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r" _
               '                 & " " & Chr(34) & NameZipFile & Chr(34) _
               '                 & " " & Chr(34) & FolderName & "*.txt" & Chr(34)

      'Zip all files in the folder and subfolders with a name that start with Week
      '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r" _
               '                 & " " & Chr(34) & NameZipFile & Chr(34) _
               '                 & " " & Chr(34) & FolderName & "Week*.*" & Chr(34)

      'Zip every file with the name ron.xls in the folder and subfolders
      '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r" _
               '                 & " " & Chr(34) & NameZipFile & Chr(34) _
               '                 & " " & Chr(34) & FolderName & "ron.xls" & Chr(34)

      'Add -s like this -sYourPassWordHere if you want to add a password to the files in the zip
      '        Password = """TopSecret"""    'Do not remove the six quotes
      '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r -s" & Password _
               '                 & " " & Chr(34) & NameZipFile & Chr(34) _
               '                 & " " & Chr(34) & FolderName & "*.*" & Chr(34)


      'Use ShellAndWait to run the ShellStr
      ShellAndWait ShellStr, vbHide
      If Dir(NameZipFile) <> "" Then
          MsgBox "You will find the zip file here: " & NameZipFile
      End If

  End If
End Sub


'With this example you zip a fixed folder: FolderName = "C:\Users\Ron\Desktop\TestFolder"
'Note this folder must exist, this is the only thing that you must change before you test it
'The zip file will be saved in: DefPath = Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'You can change this folder to this if you want to use another folder
'DefPath = "C:\Users\Ron\ZipFolder"

Sub B_Zip_Fixed_Folder_And_SubFolders_WinZip()
  Dim PathZipProgram As String, NameZipFile As String, FolderName As String
  Dim ShellStr As String, strDate As String, DefPath As String

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Create Path and name of the new zip file
  'The zip file will be saved in: DefPath = Application.DefaultFilePath
  'Normal if you have not change it this will be your Documents folder
  'You can change the folder if you want to another folder like this
  'DefPath = "C:\Users\Ron\ZipFolder"
  DefPath = Application.DefaultFilePath
  If Right(DefPath, 1) <> "\" Then
      DefPath = DefPath & "\"
  End If

  'Create date/Time string, also the name of the Zip in this example
  strDate = Format(Now, "yyyy-mm-dd hh-mm-ss")

  'Set NameZipFile to the full path/name of the Zip file
  'If you want to add the word "MyZip" before the date/time use
  'NameZipFile = DefPath & "MyZip " & strDate & ".zip"
  NameZipFile = DefPath & strDate & ".zip"

  'Fill in the folder name that you want to zip
  FolderName = "C:\Users\Ron\Desktop\TestFolder"
  If Right(FolderName, 1) <> "\" Then
      FolderName = FolderName & "\"
  End If

  'If the folder not exist stop the macro
  If Dir(FolderName) = "" Then Exit Sub

  On Error Resume Next

  'Zip all the files in the folder and subfolders, -r is Include subfolders
  'If you add -p, WinZip will store folder information for all files added,
  'not just for files from subfolders; the folder information will begin with
  'the folder specified on the command line.
  ShellStr = PathZipProgram & "Winzip32.exe -min -a -r" _
           & " " & Chr(34) & NameZipFile & Chr(34) _
           & " " & Chr(34) & FolderName & "*.*" & Chr(34)

  'Note: you can replace the ShellStr with one of the example ShellStrings
  'in the first macro example on this page

  'Use ShellAndWait to run the ShellStr
  ShellAndWait ShellStr, vbHide
  If Dir(NameZipFile) <> "" Then
      MsgBox "You will find the zip file here: " & NameZipFile
  End If

End Sub


'With this example you browse to the folder you want and select the files that you want to zip
'Use the Ctrl key to select more then one file or select blocks of files with the shift key pressed.
'With Ctrl a you select all files in the dialog.
'The name of the zip file will be the Date/Time, you can change the NameZipFile string
'If you want to add the word "MyZip" before the date/time use
'NameZipFile = DefPath & "MyZip " & strDate & ".zip"
'The zip file will be saved in: DefPath = Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'You can change this folder to this if you want to use another folder
'DefPath = "C:\Users\Ron\ZipFolder"
'No need to change the code before you test it

Sub C_Zip_File_Or_Files_Browse_WinZip()
  Dim PathZipProgram As String, NameZipFile As String, FolderName As String
  Dim ShellStr As String, strDate As String, DefPath As String
  Dim NameList As String, sFileNameXls As String
  Dim vArr As Variant, FileNameXls As Variant, iCtr As Long

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Create Path and name of the new zip file
  'The zip file will be saved in: DefPath = Application.DefaultFilePath
  'Normal if you have not change it this will be your Documents folder
  'You can change the folder if you want to another folder like this
  'DefPath = "C:\Users\Ron\ZipFolder"
  DefPath = Application.DefaultFilePath
  If Right(DefPath, 1) <> "\" Then
      DefPath = DefPath & "\"
  End If

  'Create date/Time string, also the name of the Zip in this example
  strDate = Format(Now, "yyyy-mm-dd hh-mm-ss")

  'Set NameZipFile to the full path/name of the Zip file
  'If you want to add the word "MyZip" before the date/time use
  'NameZipFile = DefPath & "MyZip " & strDate & ".zip"
  NameZipFile = DefPath & strDate & ".zip"

  FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
                                            MultiSelect:=True, Title:="Select the files that you want to add to the new zip file")

  If IsArray(FileNameXls) = False Then
      'do nothing
  Else
      NameList = ""
      For iCtr = LBound(FileNameXls) To UBound(FileNameXls)
          NameList = NameList & " " & Chr(34) & FileNameXls(iCtr) & Chr(34)
          vArr = Split(FileNameXls(iCtr), "\")
          sFileNameXls = vArr(UBound(vArr))

          If bIsBookOpen(sFileNameXls) Then
              MsgBox "You can't zip a file that is open!" & vbLf & _
                     "Please close: " & FileNameXls(iCtr)
              Exit Sub
          End If
      Next iCtr

      On Error Resume Next

      'Zip every file you have selected with GetOpenFilename
      ShellStr = PathZipProgram & "winzip32.exe -min -a" _
               & " " & Chr(34) & NameZipFile & Chr(34) _
               & " " & NameList

      'Use ShellAndWait to run the ShellStr
      ShellAndWait ShellStr, vbHide
      If Dir(NameZipFile) <> "" Then
          MsgBox "You will find the zip file here: " & NameZipFile
      End If
  End If

End Sub


'Update older files in the archive and add files that are not in the archive
'With this example you can browse to the folder and select the files that you want
'Use the Ctrl key to select more then one file or select blocks of files with the shift key pressed.
'With Ctrl a you select all files in the dialog.
'Change this code line to your path and name of the zip file :
'NameZipFile = "C:\Users\Ron\ZipFolder\ron.zip"

Sub D_Zip_File_Or_Files_Browse_Add_Update_WinZip()
'Update older files in the archive and add files that are not in the archive
'Change NameZipFile in the code to your zip file before you run the code
  Dim PathZipProgram As String, NameZipFile As String, FolderName As String
  Dim ShellStr As String, iCtr As Long
  Dim NameList As String, sFileNameXls As String
  Dim vArr As Variant, FileNameXls As Variant

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Set NameZipFile to the full path/name of the Zip file
  NameZipFile = "C:\Users\Ron\ZipFolder\ron.zip"

  'If the zip file not exist stop the macro
  If Dir(NameZipFile) = "" Then Exit Sub

  FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
                                            MultiSelect:=True, Title:="Select the files that you want to update or add to the zip file")

  If IsArray(FileNameXls) = False Then
      'do nothing
  Else
      NameList = ""
      For iCtr = LBound(FileNameXls) To UBound(FileNameXls)
          NameList = NameList & " " & Chr(34) & FileNameXls(iCtr) & Chr(34)
          vArr = Split(FileNameXls(iCtr), "\")
          sFileNameXls = vArr(UBound(vArr))

          If bIsBookOpen(sFileNameXls) Then
              MsgBox "You can't zip a file that is open!" & vbLf & _
                     "Please close: " & FileNameXls(iCtr)
              Exit Sub
          End If
      Next iCtr

      On Error Resume Next

      'Zip every file you have selected with GetOpenFilename
      ShellStr = PathZipProgram & "winzip32.exe -min -u" _
               & " " & Chr(34) & NameZipFile & Chr(34) _
               & " " & NameList

      'Use ShellAndWait to run the ShellStr
      ShellAndWait ShellStr, vbHide
      MsgBox "You will find the zip file here: " & NameZipFile
  End If

End Sub


'With this example you zip the ActiveWorkbook
'The name of the zip file will be the name of the workbook + Date/Time
'The zip file will be saved in: DefPath = Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'You can change this folder to this if you want to use another folder
'DefPath = "C:\Users\Ron\ZipFolder"
'There is no need to change the code before you test it

Sub E_Zip_ActiveWorkbook_WinZip()
  Dim PathZipProgram As String, NameZipFile As String
  Dim ShellStr As String, strDate As String, DefPath As String
  Dim FileNameXls As String, TempFilePath As String, TempFileName As String
  Dim MyWb As Workbook, FileExtStr As String

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Build the path and name for the new xls? file
  Set MyWb = ActiveWorkbook
  If ActiveWorkbook.Path = "" Then Exit Sub

  TempFilePath = Environ$("temp") & "\"
  FileExtStr = "." & LCase(Right(MyWb.Name, _
                                 Len(MyWb.Name) - InStrRev(MyWb.Name, ".", , 1)))
  TempFileName = Left(MyWb.Name, Len(MyWb.Name) - Len(FileExtStr))

  'Use SaveCopyAs to make a copy of the file
  FileNameXls = TempFilePath & TempFileName & FileExtStr
  MyWb.SaveCopyAs FileNameXls

  'Build the path and name for the new zip file
  'The name of the zip file will be the name of the workbook + Date/Time
  'The zip file will be saved in: DefPath = Application.DefaultFilePath
  'Normal if you have not change it this will be your Documents folder.
  'You can change this folder to this if you want to use another folder
  'DefPath = "C:\Users\Ron\ZipFolder"
  DefPath = Application.DefaultFilePath
  If Right(DefPath, 1) <> "\" Then
      DefPath = DefPath & "\"
  End If
  strDate = Format(Now, "yyyy-mm-dd hh-mm-ss")
  NameZipFile = DefPath & TempFileName & " " & strDate & ".zip"

  On Error Resume Next

  'Zip FileNameXls (copy of the ActiveWorkbook)
  ShellStr = PathZipProgram & "winzip32.exe -min -a" _
           & " " & Chr(34) & NameZipFile & Chr(34) _
           & " " & Chr(34) & FileNameXls & Chr(34)

  'Use ShellAndWait to run the ShellStr
  ShellAndWait ShellStr, vbHide
  If Dir(NameZipFile) <> "" Then
      MsgBox "You will find the zip file here: " & NameZipFile
  End If

  'Delete the file that you saved with SaveCopyAs and add to the zip file
  Kill FileNameXls

End Sub


'Note: This will only work if you use Outlook 2000-2007 as your mail program
'With this example you will send a zip file with a newly created workbook (copy of the Activeworkbook)
'The name of the zip file will be the name of the workbook + Date/Time
'After the zip file is sent the zip file and the workbook will be deleted from your hard disk
'There is no need to change the code before you test it

Sub F_Zip_Mail_ActiveWorkbook_WinZip()
  Dim PathZipProgram As String, NameZipFile As String
  Dim ShellStr As String, strDate As String
  Dim FileNameXls As String, TempFilePath As String, TempFileName As String
  Dim MyWb As Workbook, FileExtStr As String

  Dim OutApp As Object
  Dim OutMail As Object

  'Path of the Zip program
  PathZipProgram = "C:\program files\winzip"
  If Right(PathZipProgram, 1) <> "\" Then
      PathZipProgram = PathZipProgram & "\"
  End If

  'Check if this is the path where WinZip is installed.
  If Dir(PathZipProgram & "winzip32.exe") = "" Then
      MsgBox "Please find your copy of winzip32.exe and try again"
      Exit Sub
  End If

  'Build the path and name for the new xls? file
  Set MyWb = ActiveWorkbook
  If ActiveWorkbook.Path = "" Then Exit Sub

  TempFilePath = Environ$("temp") & "\"
  FileExtStr = "." & LCase(Right(MyWb.Name, _
                                 Len(MyWb.Name) - InStrRev(MyWb.Name, ".", , 1)))
  TempFileName = Left(MyWb.Name, Len(MyWb.Name) - Len(FileExtStr))

  'Use SaveCopyAs to make a copy of the file
  FileNameXls = TempFilePath & TempFileName & FileExtStr
  MyWb.SaveCopyAs FileNameXls

  'Build the path and name for the new zip file
  'The name of the zip file will be the name of the workbook + Date/Time
  strDate = Format(Now, "yyyy-mm-dd hh-mm-ss")
  NameZipFile = TempFilePath & TempFileName & " " & strDate & ".zip"

  On Error Resume Next

  'Zip FileNameXls (copy of the ActiveWorkbook)
  ShellStr = PathZipProgram & "winzip32.exe -min -a" _
           & " " & Chr(34) & NameZipFile & Chr(34) _
           & " " & Chr(34) & FileNameXls & Chr(34)

  'Use ShellAndWait to run the ShellStr
  ShellAndWait ShellStr, vbHide
  If Dir(NameZipFile) <> "" Then

      Set OutApp = CreateObject("Outlook.Application")
      OutApp.Session.Logon
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
          .To = "ron@debruin.nl"
          .CC = ""
          .BCC = ""
          .Subject = "ZipMailTest"
          .Body = "Here is the File"
          .Attachments.Add NameZipFile
          .Display    ' or use .Send
      End With
      Set OutMail = Nothing
      Set OutApp = Nothing

      'Delete the zip file after you send the mail
      Kill NameZipFile
  End If

  'Delete the file that you saved with SaveCopyAs and add to the zip file
  Kill FileNameXls

End Sub

Cumprimentos!

Este tópico o ajudou? Agradecer não custa nada e ainda nos motiva a continuar lhe ajudando. Então que tal dar um joinha ?

Jeferson, O código é muito extenso.

Tive verificando o meu utilitário de backup e na verdade ele não faz do diretório todo e sim do FE e BE. Como utiliza de scripts é possível ser alterado para atender a sua necessidade.

Segue abaixo que chama o utilitário ao sair do sistema.

Código:

Private Sub sair_Click()
Playsound ("C:\GTEC\Objetos\Sound\Menu")
Dim strcmd As String
Dim objaccess As Access.Application
strcmd = SysCmd(acSysCmdAccessDir) & "\msaccess.exe " & "C:\GTEC\Ferramentas\backup\Gerenciador.accdb"
Call Shell(strcmd, vbNormalFocus)
DoEvents:
Set objaccess = GetObject("C:\GTEC\Ferramentas\backup\Gerenciador.accdb")
DoCmd.Quit
End Sub

Anexo o utilitário Access 2007 - Win7 64 bits

Abraços,

Jeferson,

Algum avanço ou novidades referente ao tópico?


Abraços,

Olá amigo Uilson,

Então ainda não consegui nada. Na verdade era para ser um modo de fazer backup de um aplicativo ou seja, pegando a pasta pai do mesmo, mas como não consegui tentei outro modo que é criar pastas em um determinado diretório e então copiar a pasta do aplicativo para lá. Em breve vou postar um exemplo para você ver!

Obrigado pela ajuda amigão!

Cumprimentos!

Este tópico o ajudou? Agradecer não custa nada e ainda nos motiva a continuar lhe ajudando. Então que tal dar um joinha [color=#339999]?[/color

Valeu Jeferson,

Ficaremos aguardando as novidades.


Abraços,