✅ Macro en Excel para Comprimir archivo en ZIP y Enviarlo por correo

🔥 En este video te voy a regalar una Macro de Excel que te permitirá comprimir un archivo en ZIP con contraseña, para luego ser enviado por correo electrónico usando Outlook de Office.

👉 Es necesario tener Outlook de Office y 7-Zip instalado.

Ver video Comprimir en archivo ZIP y enviar por correo desde Excel

Suscríbete al canal de EXCELeINFO en YouTube para aprender más de Excel y macros.

Requisitos previos

Para que la funcione sin problemas, recomiendo asegurarte de tener lo siguiente.

• Outlook de Office con mínimo una cuenta configurada.
• 7-Zip instalado.
• Activar la librería Microsoft Outlook 16.0 Object Library (ver video).

Qué hace la macro

Más bien diría, qué no hace macro.

Parte importante de la macro es autoría de Ron de Bruin, MVP de Excel. Rob publicó aquí un código para comprimir archivos desde VBA en Excel.

Para hacer el envío del archivo ZIP usamos parte de esta macro que publiqué en este mismo sitio.

En resumidas cuentas, la macro hace lo siguiente:

• Guarda una copia del archivo activo.
• La comprimes en ZIP.
• Le asigna una contraseña al ZIP.
• Se envía por correo electrónico usando Outlook.

Código VBA de la macro

Option Explicit
'Mi canal de YouTube | youtube.com/user/sergioacamposh
'Mi Sitio | exceleinfo.com
'Descarga mi add-in | addin.exceleinfo.com
'Obtén la Certificación Excel Expert | exceleinfo.com/certificacion-mos

'Ron de Bruin - Excel Automation
'https://www.rondebruin.nl/win/s7/win003.htm
#If VBA7 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long
    
    Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#Else
    Private Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long
    
    Private Declare Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#End If

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

Sub ZIPyCorreo()

'Declaramos variables
Dim Pregunta As Byte

Dim PathZipProgram As String, NameZipFile As String
Dim ComandoZIP As String
Dim TempFileName As String
Dim MyWb As Workbook, FileExtStr As String

Dim Nombre As String, RutaTemporal As String
Dim NombreArchivo As String, Pass As String

Dim OutlookApp As New Outlook.Application
Dim MItem As Outlook.MailItem

'Preguntamos si deseamos continuar
Pregunta = MsgBox("Deseas enviar el archivo actual por correo en ZIP y con contraseña?", vbYesNo + vbQuestion)
If Pregunta = vbNo Then Exit Sub

'Validamos si el archivo está guardado
Set MyWb = ActiveWorkbook
If MyWb.Path = "" Then MsgBox "El archivo no está guardado.", vbExclamation: Exit Sub
    
'Devolvemos el nombre del archivo sin extensión
FileExtStr = "." & LCase(Right(MyWb.Name, _
                               Len(MyWb.Name) - InStrRev(MyWb.Name, ".", , 1)))
TempFileName = Left(MyWb.Name, Len(MyWb.Name) - Len(FileExtStr))

'Path of the Zip program
PathZipProgram = "C:\program files\7-Zip\"

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

'Definimos una ruta temporal para guardar el archivo
Nombre = MyWb.Name
RutaTemporal = Environ("temp") & "\"
NombreArchivo = RutaTemporal & Nombre

'Hacemos una copia del archivo activo
ActiveWorkbook.SaveCopyAs NombreArchivo
   
NameZipFile = RutaTemporal & TempFileName & ".zip"
    
Pass = "PSW-" & VBA.Fix(VBA.Rnd() * 1000)

'Creamos el comando que se ejecutará para comprimir el archivo

ComandoZIP = PathZipProgram & "7z.exe a -r -p" & Pass _
                 & " " & Chr(34) & NameZipFile & Chr(34) _
                 & " " & Chr(34) & NombreArchivo

ShellAndWait ComandoZIP, vbHide

'Enviamos correo con el ZIP adjunto
Set OutlookApp = New Outlook.Application
Set MItem = OutlookApp.CreateItem(olMailItem)

With MItem
    .To = "sergio@exceleinfo.com"
    .Subject = "Archivo zip"
    .Body = Pass
    .Attachments.Add NameZipFile
    .SendUsingAccount = OutlookApp.Session.Accounts.Item(1)
    .Send
End With

Set MItem = Nothing
Set OutlookApp = Nothing

'Eliminamos la copia del archivo y el archivo ZIP
Kill NombreArchivo
Kill NameZipFile

End Sub

Descarga el archivo para practicar

Archivo de prueba dentro de un ZIP con contraseña – EXCELeINFO.zip

⭐ Si te gustó este tutorial, por favor regístrate en nuestra Lista de correo y Suscríbete a nuestro canal de YouTube para que estés siempre enterado de lo nuevo que publicamos.