[Resolvido]Comprimir com WinRar seja no Office 32 ou 64

Boa tarde Amigos

Na rotina abaixo que deteta qual o Office 32 ou 64 como, unir os dois código e ler o que necessita.
Códigos a unir:

Porque ao ser executada a que estiver primeiro é que conta, se a outra estiver desativada.

Caso nenhuma estiver desativada não comprime

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
 'Windows 10 64 - winrar 64 - Office 2013 32

      If Len(Dir("PROGRAMFILES") & "\Winrar\WinRar.EXE") & "" > 0 Then
     
       WinRarPath = "C:\Program Files\WinRar\"
   End If

 '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  'Windows 10 64 - winrar 64 - Office 2016 64
 
  If Len(Dir("C:\Program Files (x86)\") & "Winrar\WinRAR.EXE") & "" > 0 Then
     
        WinRarPath = "C:\Program Files (x86)\WinRar\"
   End If
   
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


Rotina completa abaixo:

Sub ComprimePastaComWinRar()

Dim Msg As String
On Error GoTo 1

'*******************************************
   Dim FSO As Object
   Dim FromPath As String
   Dim ToPath As String
   Dim WinRarPath As String 'Localização do WinRar.exe
   Dim RarIt As String 'Instrução de linha de comando
   Dim SourceDir As String 'O diretório de origem
   Dim DestDir As String 'O diretório de destino
   Dim DestRarName As String
   Dim Dest As String 'Caminho de destino concatenado
   FromPath = Me!CaminhoEscolhido
   ToPath = Me!CaminhoEscolhido
   'inicia a criação da pasta
   Set fs = CreateObject("Scripting.FileSystemObject")
   'se a pasta existir, deleta
   
      If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
   End If
   If Right(ToPath, 1) = "\" Then
       ToPath = Left(ToPath, Len(ToPath) - 1)
   End If
   Set FSO = CreateObject("scripting.filesystemobject")
   If FSO.FolderExists(FromPath) = False Then
       MsgBox FromPath & " Não Existe."
       Exit Sub
   End If
   'copia
   FSO.CopyFolder Source:=FromPath, Destination:=ToPath
   

     '*** Verifica se existe instalação do WinRar ***

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
 'Windows 10 64 - winrar 64 - Office 2013 32

      If Len(Dir("PROGRAMFILES") & "\Winrar\WinRar.EXE") & "" > 0 Then
     
       WinRarPath = "C:\Program Files\WinRar\"
   End If

 '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  'Windows 10 64 - winrar 64 - Office 2016 64
 
  If Len(Dir("C:\Program Files (x86)\") & "Winrar\WinRAR.EXE") & "" > 0 Then
     
        WinRarPath = "C:\Program Files (x86)\WinRar\"
   End If
   
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
   

   SourceDir = Me.CaminhoEscolhido

    'Verifica se a Pasta tem espaços nos nomes
   If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
   
   'Letra do Drive de destino
   DestDir = Me.CaminhoEscolhido
   
 
   If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
    DestRarName = "Backup.Rar"
    Dest = DestDir & "\" & DestRarName

   If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
   
          RarIt = shell(WinRarPath & "Winrar.exe a -r " & Dest & " " & SourceDir, vbHide)
   
    MsgBox "Backup Complecto Criado com Sucesso...", vbInformation, "" & DLookup("[Programa]", "Proprietario") & " " & DLookup("[Tipo]", "Proprietario")

       Me.Rótulo11.Caption = "A Compactar ..."
volta:
           If ProgramaAtivo("WinRar") = True Then
               Pause (5)
               GoTo volta
           End If

Call Comando25_Click


Exit_1:
   DoCmd.Hourglass False
   DoCmd.Echo True
   Exit Sub

1 A:
   DoCmd.Hourglass False
   DoCmd.Echo True
   Msg = "Erro # " & Str(Err.Number) & " gerado na " & Err.Source _
       & vbNewLine & vbNewLine & "Descrição: " & Err.Description _
       & vbNewLine & vbNewLine & "Por favor contate o Administrador de Sistema."
   MsgBox Msg, vbMsgBoxHelpButton + vbCritical, "Erro", Err.HelpFile, Err.HelpContext
   Resume Exit_1

End Sub

Obrigado

Olá Assis,

Vou dar o simples, eu uso desta forma para obter e verificar se tem WinRar:

Código:

Public Function pathWinRar() As String
'Álvaro Teixeira (ahteixeira) 2021
'Obter caminho do WinRar, para verificar fazer algo assim:
'   If Len(pathWinRar() & "") > 0 Then  ...
'Pode ser necessária referencia a "Microsoft Scripting Runtime"
    On Error Resume Next
    Dim WSHShell
    Set WSHShell = CreateObject("WScript.Shell")
    pathWinRar = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRar.EXE\")
End Function

Se quiser usar desta forma é só ajustar o seu código.

Abraço

Teixeira

Como chamar a sua dica ?
A sua dica tem que estar num módulo, ou pode estar no mesmo formulário onde está a minha rotina ?

Obrigado

Olá Assis,

Ela está "Public Function" para ser colocada num modulo e poder ser utilizada em varios formularios, etc.
Se no seu projeto só vai usar num determinado form, pode colocar nesse mesmo e alterar para "private" ou retirar o "public".

Abraço

Olá Assis,

Lebrei deste excelente exemplo do DamascenoJr, já pronto:
https://www.maximoaccess.com/t38668-zipar-pastas-e-arquivos-com-o-winrar

Fica mais esta opção.

Abraço

Assis

Se analisasse o código enviado pelo Álvaro,

saberia onde coloca-lo.

Balem

Assis, talvez uma releitura de um tópico de sua autoria também ajude em algo.

https://www.maximoaccess.com/t37973-resolvidoverificar-se-existe-winrar-exe-no-windows-64-e-32-bit

Boa noite Assis!

Não seria melhor usar a versão de linha de comando do Winrar.
Vc não precisaria saber se o Winrar está ou não instalado, é um arquivo de apenas 400KB, que pode ir na pasta do seu sistema. Funciona em 32 e 64 bits

Saludos

Bom dia Franklin

O meu problema não é saber se tem ou não WinRar instalado.

O meu problema é ter que ter duas bases de dados iguais a funcionar em 32 e 64, mas com o sistema de Backup diferente.

Isso obriga-me a sempre que fizer uma alteração no 32 ter que fazer as mesmas alterações no 64.


Se eu estou no Office 32 eu uso o código abaixo e tudo sai perfeito. Copia para onde eu quero a pasta toda, e no fim compacta tudo.

'Windows 10 64 - winrar 64 - Office 2013 32

     If Len(Dir("PROGRAMFILES") & "\Winrar\WinRar.EXE") & "" > 0 Then
   
      WinRarPath = "C:\Program Files\WinRar\"
  End If

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


Se eu estou no Office 64 eu uso o código abaixo e tudo sai perfeito. Copia para onde eu quero a pasta toda, e no fim compacta tudo.

 'Windows 10 64 - winrar 64 - Office 2016 64

 If Len(Dir("C:\Program Files (x86)\") & "Winrar\WinRAR.EXE") & "" > 0 Then
   
       WinRarPath = "C:\Program Files (x86)\WinRar\"
  End If
 
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

Diz o Franklin ...

Não seria melhor usar a versão de linha de comando do Winrar. ----------> qual é esta esta linha e como aplicar na minha rotina da mensagem Nº 1?

Obrigado

Creio que isso ajude:


#If Win64 Then
     MsgBox "Aqui você colocar o winrar 64 Bits"
#Else
     MsgBox "Aqui o winrar de 32 bits"
#End If


{ }'s

Balem

Olá a todos,

Assis, como diz o nosso amigo JPaulo, "existe muitas formas de fazer Nestum" que significa que podemos obter o mesmo resultado de diversas formas.

Eu dei a minha sugestão, e se o seu código da mensagem nr. 1 estiver a funcionar com uma linha de código resolve o problema, é necessário colocar no local certo (e colocar o modulo, é melhor dizer para nao ficar dúvidas).

O colega Damasceno até avisou que a dúvida é recorrente, e concordo plenamente, podemos pedir ajudar, copiar e colar, mas também devemos olhar para o codigo e perceber o que ele está a fazer, como, quando e onde.
Só desta forma é que você pode avancar para um novo patamar.

A melhor forma é tentar relaxar e perceber o que o seu codigo está a fazer a última sugestão do colega Noob também é válida é só colocar no sitio correto (com as instruções que todos estamos a ver na mensagem n. 1).

É só pensar "o meu problema está na parte do 32 ou 64, tenho que alterar ...hummmm, com um IF consigo detetar se é 32 ou 64... hummmm, deixa testar com calma).

Bom almoço que vou fazer o mesmo.

Teixeira

O meu código da menagem Nº 1 funciona perfeito no Office 32 e no 64, ambos no Win 64 e WinRar 64

Coloquei o este seu código num modulo, mas não acerto com o local para e como chamar este seu código.

Obrigado

Public Function pathWinRar() As String
'Álvaro Teixeira (ahteixeira) 2021
'Obter caminho do WinRar, para verificar fazer algo assim:
' If Len(pathWinRar() & "") > 0 Then ...
'Pode ser necessária referencia a "Microsoft Scripting Runtime"
On Error Resume Next
Dim WSHShell
Set WSHShell = CreateObject("WScript.Shell")
pathWinRar = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRar.EXE\")
End Function

Olá Assis,

Se o código funciona porque abriu o tópico???
"Na rotina abaixo que deteta qual o Office 32 ou 64 como, unir os dois código e ler o que necessita."

Realmente podemos estar perante um erro de Português , ou melhor, falta de clareza (na minha opinião).

Quanto à última questão, poderia dizer onde colocar, mas você já compreendeu o que a função faz?
Já testou na janela imediata e ver o resultado?
Pode ser que ajude onde colocar com o resultado (teste em máquinas com WinRar diferentes).

Abraço

Olá Teixeira

Não brinque com os meus cabelos brancos (a foto é antiga), que só hoje tiveram um aumento de 5%.

Estou perto ?  

se a função pathwinrar já devolve o caminho com o arquivo executável (.exe), então não é necessário repetir winrar.exe em na expressão "winrar.exe a -r...

Damasceno

Não funciona

Olá a todos,

Assis, como podemos ver na imagem que partilhou (nr 14) devolve o caminho completo do winrar (se estiver instado, por isso na funcao coloquei o alerta para o IF).
No seu codigo original tem:
RarIt = shell(WinRarPath & "Winrar.exe a -r " & Dest & " " & SourceDir, vbHide)

O correto sera alterar a parte indicada a vermelho,

Abraço

Teixeira

Assim ?  

Olá Assis,

Exatamente, já deve funcionar, certo?
Se sim , deve eliminar o codigo desnecessário.
E volto a lembrar coloque o IF para o caso de ser um computador que nao tenha o WinRar instalado.

Abraço

Olá Teixeira

No Win 10 64, com Winrar 64, Office 2013 32 não funciona ...


Só amanhã poderei testar no:

No Win 10 64, com Winrar 64, Office 2016 64

Olá Assis,

e funcionava antes da alteração???

Abraço

Olá Teixeira


Win 10 64, WinRar 64, Office 2013 32

Atenção:
Tirei as linhas que correspondem ao Office 2016 64  


Funciona perfeito

Código:

Sub ComprimePastaComWinRar()

Dim Msg As String
On Error GoTo 1

'*******************************************
  Dim FSO As Object
  Dim FromPath As String
  Dim ToPath As String
  Dim WinRarPath As String 'Localização do WinRar.exe
  Dim RarIt As String 'Instrução de linha de comando
  Dim SourceDir As String 'O diretório de origem
  Dim DestDir As String 'O diretório de destino
  Dim DestRarName As String
  Dim Dest As String 'Caminho de destino concatenado
  FromPath = Me!CaminhoEscolhido
  ToPath = Me!CaminhoEscolhido
  'inicia a criação da pasta
  Set fs = CreateObject("Scripting.FileSystemObject")
  'se a pasta existir, deleta
 
     If Right(FromPath, 1) = "\" Then
       FromPath = Left(FromPath, Len(FromPath) - 1)
  End If
  If Right(ToPath, 1) = "\" Then
      ToPath = Left(ToPath, Len(ToPath) - 1)
  End If
  Set FSO = CreateObject("scripting.filesystemobject")
  If FSO.FolderExists(FromPath) = False Then
      MsgBox FromPath & " Não Existe."
      Exit Sub
  End If
  'copia
  FSO.CopyFolder Source:=FromPath, Destination:=ToPath
 

    '*** Verifica se existe instalação do WinRar ***

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'Windows 10 64 - winrar 64 - Office 2013 32

     If Len(Dir("PROGRAMFILES") & "\Winrar\WinRar.EXE") & "" > 0 Then
   
      WinRarPath = "C:\Program Files\WinRar\"
  End If

 

  SourceDir = Me.CaminhoEscolhido

   'Verifica se a Pasta tem espaços nos nomes
  If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
 
  'Letra do Drive de destino
  DestDir = Me.CaminhoEscolhido
 

  If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
   DestRarName = "Backup.Rar"
   Dest = DestDir & "\" & DestRarName

  If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
 
         RarIt = shell(WinRarPath & "Winrar.exe a -r " & Dest & " " & SourceDir, vbHide)
 
   MsgBox "Backup Complecto Criado com Sucesso...", vbInformation, "" & DLookup("[Programa]", "Proprietario") & " " & DLookup("[Tipo]", "Proprietario")

      Me.Rótulo11.Caption = "A Compactar ..."
volta:
          If ProgramaAtivo("WinRar") = True Then
              Pause (5)
              GoTo volta
          End If

Call Comando25_Click


Exit_1:
  DoCmd.Hourglass False
  DoCmd.Echo True
  Exit Sub

1 A:
  DoCmd.Hourglass False
  DoCmd.Echo True
  Msg = "Erro # " & Str(Err.Number) & " gerado na " & Err.Source _
      & vbNewLine & vbNewLine & "Descrição: " & Err.Description _
      & vbNewLine & vbNewLine & "Por favor contate o Administrador de Sistema."
  MsgBox Msg, vbMsgBoxHelpButton + vbCritical, "Erro", Err.HelpFile, Err.HelpContext
  Resume Exit_1

End Sub

Ola,

Onde tem:

Código:

      RarIt = shell(WinRarPath & "Winrar.exe a -r " & Dest & " " & SourceDir, vbHide)

altere por este

Código:

      Dim strCmd
       strCmd = pathWinRar
       RarIt = Shell(strCmd & " a -r " & Dest & " " & SourceDir, vbHide)

Abraço

Teixeira

É igual não comprime.

Obrigado

Assis,

Retire o vbHide da instrucao para ver o erro (altere para normal)

Abraco

Apareceu

Ola,

colocou assim

Código:

      Dim strCmd
       strCmd = pathWinRar
       RarIt = Shell(strCmd & " a -r " & Dest & " " & SourceDir, vbNormalFocus)

Bom dia

Com o oculto e também dá  mesmo erro do da imagem

RarIt = shell(PathWinRar & " a -r " & Dest & " " & SourceDir, vbHide)

Marque um ponto de interrupção na linha RarIt... e pergunte a janela de verificação imediata a montagem final do seu comando, pois algo de errado ele tem

? PathWinRar & " a -r " & Dest & " " & SourceDir

O código do tópico abaixo resolve
https://www.maximoaccess.com/t38668-zipar-pastas-e-arquivos-com-o-winrar

Damasceno

Já estive a ver o seu código, mas ainda não percebi como o aplicar.

Quanto a sua ultima mensagem sobre a janela imediata



Obrigado

Damasceno

Win 10 64, WinRar 64, e Office 2013 32 -----> Funciona com o seu código.  


Vou almoçar e vou testar no Win 10 64, WinRar 64, e Office 2016 64 ----> E depois retorno

Damasceno

Win 10 64, WinRar 64, e Office 2013 32 -----> Funciona com o seu código.  Laughing


Win 10 64, WinRar 64, e Office 2016 64 ----> Funciona com o seu código.  Laughing


Assim já não preciso mandar 1 programa para 8 postos com o Office 32 de trabalho, e outro para 4 postos de trabalho com o Office 2016 64.
Obrigado Mestres
Teixeira
Damasceno


PS - Obrigado Franklin enviou um exemplo que vou estudar, pode servir para outras BDs

Olá a todos,

Assis, que bom que já vê uma luz.
Quanto ao "ponto de interrupção", pode consultar neste tópico
É necessário para ser perceber onde está o erro.

Abraço

Olá Assis a última mensagem foi ao mesmo tempo

Que bom, mas fiquei sem perceber o que estava a provocar o erro, pode dar mais detalhes como ficou.
Assim serve de estudo para outros membros.

Abraço a todos

Teixeira

Foi na mensagem Nº 29, testei o exemplo do Damasceno e foi logo na primeira tentativa.

O erro não sei porque não cheguei a elimina-lo.

Quer que coloque aqui o código do comprimir ?

Eu coloco e depois o Amigo apaga as mensagens que não tem interesse

Obrigado.  

' ********* Código ********************

Sub ComprimePastaComWinRar()

Dim Msg As String
On Error GoTo 1

   Dim FSO As Object
   Dim FromPath As String
   Dim ToPath As String
   Dim RarIt As String 'Instrução de linha de comando
   Dim SourceDir As String 'O diretório de origem
   Dim DestDir As String 'O diretório de destino
   Dim DestRarName As String
   Dim Dest As String 'Caminho de destino concatenado
   FromPath = Me!CaminhoEscolhido
   ToPath = Me!CaminhoEscolhido
   'inicia a criação da pasta
   Set fs = CreateObject("Scripting.FileSystemObject")
   'se a pasta existir, deleta
   
   If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
   End If
   If Right(ToPath, 1) = "\" Then
       ToPath = Left(ToPath, Len(ToPath) - 1)
   End If
   Set FSO = CreateObject("scripting.filesystemobject")
   If FSO.FolderExists(FromPath) = False Then
       MsgBox FromPath & " Não Existe."
       Exit Sub
   End If
   'copia
   FSO.CopyFolder Source:=FromPath, Destination:=ToPath
   

   SourceDir = Me.CaminhoEscolhido

    'Verifica se a Pasta tem espaços nos nomes
   If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
   
   'Letra do Drive de destino
   DestDir = Me.CaminhoEscolhido
   
 
   If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
     DestRarName = "Backup.Rar"
        Dest = DestDir & "\" & DestRarName

   If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
   
          RarIt = shell(fncDirWinRAR & " a -r " & Dest & " " & SourceDir, vbHide)
         
    MsgBox "Backup Complecto Criado com Sucesso...", vbInformation, "Aviso"

       Me.Rótulo11.Caption = "A Compactar ..."
     
volta:
       If ProgramaAtivo("WinRar") = True Then
          Pause (5)
           GoTo volta
       End If

'Call Comando25_Click


Exit_1:
   DoCmd.Hourglass False
   DoCmd.Echo True
   Exit Sub

1 A:
   DoCmd.Hourglass False
   DoCmd.Echo True
   Msg = "Erro # " & Str(Err.Number) & " gerado na " & Err.Source _
       & vbNewLine & vbNewLine & "Descrição: " & Err.Description _
       & vbNewLine & vbNewLine & "Por favor contate o Administrador de Sistema."
   MsgBox Msg, vbMsgBoxHelpButton + vbCritical, "Erro", Err.HelpFile, Err.HelpContext
   Resume Exit_1

End Sub