MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access


3 participantes

    [Resolvido]Script de Beckup Winrar.

    XPTOS
    XPTOS
    Super Avançado
    Super Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 601
    Registrado : 20/01/2014

    [Resolvido]Script de Beckup Winrar. Empty [Resolvido]Script de Beckup Winrar.

    Mensagem  XPTOS 20/5/2014, 21:42

    Prezados!

    Dim strlocal
    Dim objws

    Apreciei este código no projeto Maestro do Avelino e tenho a seguinte dúvida. É possível rodar esse script pelo agendador de tarefas do windows de modo que ele possa compactar o meu BE pelo Winrar?



    on error resume next

    Set objws = CreateObject("wscript.shell")

    strlocal = "C:\Users\wagomes\Desktop\Base dados SAC\SAC - Sistema de Análise de Contas 2007.accdb" ' caminho do meu banco

    'ch(34) = Aspas

    strlocal = Chr(34) & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & strlocal & Chr(34)

    '0 - oculto
    '5 - visivel

    ObjWS.Run strlocal, 0,"false"
    XPTOS
    XPTOS
    Super Avançado
    Super Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 601
    Registrado : 20/01/2014

    [Resolvido]Script de Beckup Winrar. Empty Re: [Resolvido]Script de Beckup Winrar.

    Mensagem  XPTOS 24/5/2014, 02:59

    UP.
    Avelino Sampaio
    Avelino Sampaio
    Developer
    Developer


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3890
    Registrado : 04/04/2010

    [Resolvido]Script de Beckup Winrar. Empty Re: [Resolvido]Script de Beckup Winrar.

    Mensagem  Avelino Sampaio 24/5/2014, 09:05

    Olá!

    Abra o aplicativo backup_at.accdb oferecido neste meu artigo:

    http://www.usandoaccess.com.br/tutoriais/tuto14.asp?id=1#inicio

    E altere o código para:

    Option Compare Database
    Option Explicit

    Public Function fncbackup()
    Dim booResultado As Boolean
    Dim objws As Object
    Dim objfs As Object
    Dim strOrigem As String
    Dim strDestino As String
    Dim strDestinoNovo As String
    Dim strLocalWinRar As String
    Dim compri

    On Error GoTo trataerro

    '--------------------------------------------------------------------
    'AQUI VOCÊ TROCA PARA O CAMINHO E PARA O NOME DO SEU BACK-END
    '---------------------------------------------------------------------
    strOrigem = "c:\Maestro\Maestro_v5_be.accdb"
    strDestino = "c:\Maestro\backup\Maestro_v5_be" & Format(Date, "ddmmyy") & "-" & Format(Time, "hhmmss") & ".accdb"

    Set objfs = CreateObject("Scripting.FileSystemObject")
    '-----------------------------
    'Realiza uma copia o Back-end
    '-----------------------------
    objfs.CopyFile strOrigem, strDestino
    '---------------------------------------------------------------
    'Entra com a senha de acesso do back-end ao compactar e reparar
    '--------------------------------------------------------------
    Set objws = CreateObject("wscript.shell")
    objws.SendKeys "a1234", True
    objws.SendKeys "{ENTER}"
    strDestinoNovo = Replace(strDestino, "-", "-c")
    booResultado = Application.CompactRepair(strDestino, strDestinoNovo, True)
    '------------------------------------------
    'Deleta a copia do back-end não compactada
    '------------------------------------------
    If booResultado = True Then FileSystem.Kill strDestino

    '------------------------------------
    'Empacota o back-end com o Winrar
    '------------------------------------
    If Len(Dir(Environ("PROGRAMFILES(x86)") & "\Winrar\WinRAR.EXE") & "") > 0 Then
       strLocalWinRar = Environ("programFiles(x86)")
    Else
       strLocalWinRar = Environ("programFiles")
    End If
    compri = Shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Replace(strDestinoNovo, ".accdb", "") & ".rar " & strDestinoNovo, vbHide)

    '----------------------------------------------------------------
    'Deleta a copia do back-end, sobrando apenas a copia do Winrar
    '----------------------------------------------------------------
    If booResultado = True Then FileSystem.Kill strDestinoNovo

    Set objws = Nothing
    Set objfs = Nothing
           
    If Len(Dir(Left(strDestino, InStrRev(strDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
       MsgBox "Foi detectado problemas no arquivo de backup." & vbCrLf & _
       vbCrLf & "Entre em contato imediatamente com o administrador do Banco de Dados", vbCritical, "Aviso"
    End If

    sair:
       DoCmd.Quit acQuitSaveAll
       Exit Function
    trataerro:
       MsgBox Err.Number & " - " & Err.Description, vbInformation, "Aviso"
       Resume sair
    End Function


    Nota:  altere a linha abaixo no seu arquivo script, chamando pelo aplicativo backup_at.accdb

    strlocal = "C:\SuaPasta\Backup_at.accdb"

    Sucesso!


    .................................................................................
    Vídeos, livros, kit MontaRibbons e acesso vitalício ao site UsandoAcces  
    Clique AQUI e analise o custo beneficio do material oferecido.
    XPTOS
    XPTOS
    Super Avançado
    Super Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 601
    Registrado : 20/01/2014

    [Resolvido]Script de Beckup Winrar. Empty Re: [Resolvido]Script de Beckup Winrar.

    Mensagem  XPTOS 25/5/2014, 00:20

    Perfeito Avelino Sampaio...

    Grato,
    XPTOS
    XPTOS
    Super Avançado
    Super Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 601
    Registrado : 20/01/2014

    [Resolvido]Script de Beckup Winrar. Empty Script de Beckup Winrar.

    Mensagem  XPTOS 26/5/2014, 13:24

    Reabrindo tópico.

    Adaptei o código ao meu projeto, falta apenas um pequeno ajuste para ele compactar o BE.

    Se tiver uma sugestação, agradeço antecipadamente.

    Option Compare Database
    Option Explicit

    Public Function fncbackup()
    Dim booResultado As Boolean
    Dim objws As Object
    Dim objfs As Object
    Dim strOrigem As String
    Dim strDestino As String
    Dim strDestinoNovo As String
    Dim strLocalWinRar As String
    Dim compri

    On Error GoTo trataerro

    '--------------------------------------------------------------------
    'AQUI VOCÊ TROCA PARA O CAMINHO E PARA O NOME DO SEU BACK-END
    '---------------------------------------------------------------------
    strOrigem = "C:\Users\wagomes\Desktop\Base dados SAC\SAC - Sistema de Análise de Contas 2007_be.accdb"
    strDestino = "C:\Users\wagomes\Desktop\Base dados SAC\Backup_SAC\SAC - Sistema de Análise de Contas 2007_be" & Format(Date, "ddmmyy") & "-" & Format(Time, "hhmmss") & ".accdb"

    Set objfs = CreateObject("Scripting.FileSystemObject")
    '-----------------------------
    'Realiza uma copia o Back-end
    '-----------------------------
    objfs.CopyFile strOrigem, strDestino
    '---------------------------------------------------------------
    'Entra com a senha de acesso do back-end ao compactar e reparar
    '--------------------------------------------------------------
    Set objws = CreateObject("wscript.shell")
    objws.SendKeys "", True
    objws.SendKeys "{ENTER}"

    strDestinoNovo = Replace(strDestino, "-", "-c")
    booResultado = Application.CompactRepair(strDestino, strDestinoNovo, True)
    '------------------------------------------
    'Deleta a copia do back-end não compactada
    '------------------------------------------
    If booResultado = True Then FileSystem.Kill strDestino

    '------------------------------------
    'Empacota o back-end com o Winrar
    '------------------------------------
    If Len(Dir(Environ("PROGRAMFILES(x86)") & "\Winrar\WinRAR.EXE") & "") > 0 Then
    strLocalWinRar = Environ("programFiles(x86)")
    Else
    strLocalWinRar = Environ("programFiles")
    End If

    compri = Shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Chr(34) & Replace(strDestinoNovo, ".accdb", "") & ".rar" & Chr(34) & "" & Chr(34) & strDestinoNovo & Chr(34), vbHide)

    '----------------------------------------------------------------
    'Deleta a copia do back-end, sobrando apenas a copia do Winrar
    '----------------------------------------------------------------
    If booResultado = True Then FileSystem.Kill strDestinoNovo

    Set objws = Nothing
    Set objfs = Nothing

    If Len(Dir(left(strDestino, InStrRev(strDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
    MsgBox "Foi detectado problemas no arquivo de backup." & vbCrLf & _
    vbCrLf & "Entre em contato imediatamente com o administrador do Banco de Dados", vbCritical, "Aviso"
    End If

    sair:
    DoCmd.Quit acQuitSaveAll
    Exit Function
    trataerro:
    MsgBox err.Number & " - " & err.Description, vbInformation, "Aviso"
    Resume sair
    End Function


    avatar
    Milton_Nunes
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 2
    Registrado : 18/03/2023

    [Resolvido]Script de Beckup Winrar. Empty Re: [Resolvido]Script de Beckup Winrar.

    Mensagem  Milton_Nunes 17/4/2023, 11:49

    Olá pessoal
    Alguém conseguiu o arquivo do Avelino Sampaio no link acima indicado?

    No Meu aqui deu o erro 404.

    404 - Arquivo ou diretório não encontrado.
    O recurso que você está procurando pode ter sido removido, teve seu nome alterado ou está temporariamente indisponível.

    Conteúdo patrocinado


    [Resolvido]Script de Beckup Winrar. Empty Re: [Resolvido]Script de Beckup Winrar.

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 23/7/2024, 02:35