MaximoAccess

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

Obrigado

Administração do MaximoAccess

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

    Zipar pastas e arquivos com o WinRAR

    DamascenoJr.
    DamascenoJr.
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 2441
    Registrado : 22/11/2016

    Zipar pastas e arquivos com o WinRAR Empty Zipar pastas e arquivos com o WinRAR

    Mensagem  DamascenoJr. em 3/11/2020, 04:20

    Exemplo de chamada para arquivo:
    call fncZipaWinRAR("d:\Arquivo.txt","d:\Arquivo.rar")
    call fncZipaWinRAR("d:\*.txt","d:\Arquivo.rar","123")

    Exemplo de chamada para pasta:
    call fncZipaWinRAR("d:\PastaQualquer\*","d:\PastaQualquer.rar")
    call fncZipaWinRAR("d:\PastaQualquer\","d:\PastaQualquer.rar")
    call fncZipaWinRAR("d:\PastaQualquer,"d:\PastaQualquer.rar")

    Código:
    Public Sub fncZipaWinRAR(ByVal strOrigem As String, _
                            ByVal strDestino As String, _
                            Optional ByVal strSenha As String = "", _
                            Optional ByVal booEvitaAlteracao As Boolean = True, _
                            Optional ByVal booMantemOriginal As Boolean = False)
    ' ----------------------------------------------------------------
    ' Autor    : DamascenoJr. (contato@damascenojr.com.br)
    ' Data      : 02/11/2020
    ' Propósito : Zipar pasta(s) e arquivo(s) com o WinRAR
    ' ----------------------------------------------------------------

        Dim strDirWinRAR As String
       
        strDirWinRAR = fncDirWinRAR
       
        If strDirWinRAR = "" Then
            Call MsgBox("WinRAR não detectado.", vbCritical, "WinRAR")
            Exit Sub
        End If

        strDirWinRAR = strDirWinRAR & IIf(booEvitaAlteracao, " -k", "")
        strDirWinRAR = strDirWinRAR & IIf(booMantemOriginal, " a", " m")
        strDirWinRAR = strDirWinRAR & IIf(strSenha <> "", " -hp" & strSenha, "")
        strDirWinRAR = strDirWinRAR & IIf((Dir(strOrigem, vbArchive) = "") Or (Right(strOrigem, 1) Like "[\*]"), " -r", "")
        strDirWinRAR = strDirWinRAR & " -ep1 -ibck"
       
        Call Shell(strDirWinRAR & " """ & strDestino & """ """ & strOrigem & """", vbHide)

    End Sub

    Private Function fncDirWinRAR() As String
    ' ----------------------------------------------------------------
    ' Propósito : Retornar o caminho do arquivo WinRAR.exe
    ' ----------------------------------------------------------------

    On Error GoTo trataErro

        Dim objWS          As Object
        Dim strResultado    As String

        Set objWS = CreateObject("WScript.Shell")
       
        strResultado = objWS.RegRead("HKEY_LOCAL_MACHINE\" & _
                                    "SOFTWARE\" & _
                                    "Microsoft\" & _
                                    "Windows\" & _
                                    "CurrentVersion\" & _
                                    "App Paths\" & _
                                    "WinRAR.exe\Path") & "\WinRAR.exe"
                                   
        If Dir(strResultado, vbArchive) = "" Then strResultado = ""
       
    sair:
    On Error Resume Next
        Set objWS = Nothing
        fncDirWinRAR = strResultado
        Exit Function
       
    trataErro:
        strResultado = ""
        Resume sair

    End Function


    .................................................................................
    Ajude-se a ser ajudado, anexe seu projeto.
    Sempre tente entender o código,
    não somente copie e cole.
    Positive as mensagens que achar útil clicando no '+' no canto superior direito delas.

    Marcelo David gosta desta mensagem


      Data/hora atual: 25/11/2020, 13:59