Enviar correo con archivos adjuntos comprmidos
Tengo una macro que envía correos electrónicos adjuntando un archivo pdf y un xml en cada envío, dichos archivos irán comprmidos en un solo archivo; quiero lograr que si al ejecutar el proceso no encuentra alguno de los archvos para adjuntar, es decir bien sea el pdf o el xml, la macro no comprima ningún archivo y continúe con el siguiente proceso; la macro es la siguiente:
Sub ComprimirArchivosDesdeLista()
Dim SApp As Object, SApp2 As Object, FZip As Variant, myfile As Variant, myfile2 As Variant, myi As Long, myi2 As Long, cant As Long
Dim nfpres, cliente, Email, Remite, EmailRemite, archivo, ArchivoPdf, ArchivoXML, Attached As String
Dim OutApp As Object, OutMail As Object
Dim cmd As String, t As Single
Dim strFrom As String
'On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("ENVIO_CORREOS").Select
For I = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(I, "M").Value = "NO ENVIADO" Or Cells(I, "M").Value = "" Then
On Error Resume Next
npres = Range("A" & I) 'numero factura
npresxml = Range("K" & I) 'nombre XML
Attached = Range("L" & I) 'nombre attached
cliente = Range("C" & I) 'nombre cliente
Email = Range("D" & I) 'email cliente
Remite = Sheets("IMPR3").Range("C2") 'nombre comercial
EmailRemite = Sheets("CONFIGURACION").Range("B16") 'email del facturador
archivo = Range("G" & I) 'ruta del pdf que se adjuntará
Atta = ThisWorkbook.Path & "\Mis_Documentos\" & Attached & "" 'ruta del xml que se adjuntará
Set SApp = CreateObject("Shell.Application")
'*********si alguno de estos achivos no se encuentra en la carpeta, que no comprima nada y continúe.
myfile = archivo 'ruta del pdf
myfile2 = Atta 'Atta 'ruta del xml
cant = UBound(myfile)
If VarType(myfile) = vbBoolean Then
Exit Sub
End If
FZip = ActiveWorkbook.Path & "\Mis_Documentos\" & "Factura No." & npres & ".zip"
Open FZip For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
SApp.Namespace(FZip).CopyHere myfile
Application.Wait (Now + TimeValue("00:00:02"))
SApp.Namespace(FZip).CopyHere myfile2
Application.Wait (Now + TimeValue("00:00:02"))
End If
Next
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
1 Respuesta
Recomendaciones de mi canal:
Curso de macros. Consejos para empezar a programar. - YouTube
Curso de macros. Declarar variables en vba excel. - YouTube
------------------------
Prueba lo siguiente:
Sub ComprimirArchivosDesdeLista()
Dim SApp As Object, SApp2 As Object, FZip As Variant, myfile As Variant, myfile2 As Variant, myi As Long, myi2 As Long, cant As Long
Dim nfpres, cliente, Email, Remite, EmailRemite, archivo, ArchivoPdf, ArchivoXML, Attached As String
Dim OutApp As Object, OutMail As Object
Dim cmd As String, t As Single
Dim strFrom As String
'On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("ENVIO_CORREOS").Select
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, "M").Value = "NO ENVIADO" Or Cells(i, "M").Value = "" Then
On Error Resume Next
npres = Range("A" & i) 'numero factura
npresxml = Range("K" & i) 'nombre XML
Attached = Range("L" & i) 'nombre attached
cliente = Range("C" & i) 'nombre cliente
Email = Range("D" & i) 'email cliente
Remite = Sheets("IMPR3").Range("C2") 'nombre comercial
EmailRemite = Sheets("CONFIGURACION").Range("B16") 'email del facturador
archivo = Range("G" & i) 'ruta del pdf que se adjuntará
Atta = ThisWorkbook.Path & "\Mis_Documentos\" & Attached & "" 'ruta del xml que se adjuntará
'*********si alguno de estos achivos no se encuentra en la carpeta, que no comprima nada y continúe.
myfile = archivo 'ruta del pdf
myfile2 = Atta 'Atta 'ruta del xml
If Dir(myfile) <> "" Or Dir(myfile2) <> "" Then
Set SApp = CreateObject("Shell.Application")
cant = UBound(myfile)
If VarType(myfile) = vbBoolean Then
Exit Sub
End If
FZip = ActiveWorkbook.Path & "\Mis_Documentos\" & "Factura No." & npres & ".zip"
Open FZip For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
SApp.Namespace(FZip).CopyHere myfile
Application.Wait (Now + TimeValue("00:00:02"))
SApp.Namespace(FZip).CopyHere myfile2
Application.Wait (Now + TimeValue("00:00:02"))
End If
End If
Next
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub------------------------
Cursos de Macros:
Curso de macros. Metodo find completo. - YouTube
Curso de macros. Metodo find ejemplos. - YouTube
------------------------
Sal u dos Dante Amor
Hola, buen día, gracias por la modificación, le comento que hice toda la corrección, pero pese a que en alguos registros el dato "myfile2" no existe en la carpeta, el archivo se comprime, es decir el hecho de no existir dicho archivo, no impide que se genere el comprimido, ¿hay alguna manera de impedir que se haga?
Cambia a esto:
If Dir(myfile) <> "" And Dir(myfile2) <> "" Then
-----
Recomendado:
