Ejecución de código me deja el excel bloqueado
Tengo el siguiente código de visual que envía correos con un archivo adjunto. Fue una recopilación de varios retazos de código de Internet y además modificaciones propias, todo funciona correctamente el código me envía un correo a los destinatarios que le ordeno con el titulo según la celda que ordeno, con el contenido según celda que le ordeno y con un adjunto en pdf de un rango de celdas que también le ordeno.
El problema esta que luego de la ejecución exitosa de la macro el excel se queda parcialmente bloqueado, no se cuelga, se bloquea. Por ejemplo, luego de la ejecución de la macro si pinto una celda de color amarillo después no la puedo despintar es como si se bloqueara donde dice " Sin relleno" o por ejemplo el botón "establecer área de impresión" esta como congelado. Muy aparte de esto Excel queda muy lento, tal vez se deba a un bucle, pero no logro encontrarlo. Agradecería su ayuda le mando el código.
*******************************
Sub ENVIO_DE_CORREOS()
'Definiciones para el correo
Dim Email As CDO.Message
Dim Remitente As String
Dim Pass As String
Dim Destinatario As String
Dim Asunto As String
Dim Cuerpo As String
'Definiciones para archivo
Dim RutaTemporal As String
Dim NombreTemporal As String
Dim RutaCompleta
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Creación del archivo temporal
RutaTemporal = Environ$("temp") & "\"
NombreTemporal = Sheets("203-301").Range("G8") & ".pdf"
RutaCompleta = RutaTemporal & NombreTemporal
On Error GoTo Err
Sheets("203-301").Range("A1:F17").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=RutaCompleta, _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
openafterpublish:=False
'Información para el correo
Set Email = New CDO.Message
Remitente = "[email protected]"
Pass = "xxxx"
Destinatario = "[email protected],[email protected]"
Asunto = Sheets("203-301").Range("G3")
Cuerpo = Sheets("203-301").Range("G6")
Email.CC = "[email protected]"
Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
Email.Configuration.Fields(cdoSendUsingMethod) = 2
With Email.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(25)
.Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Remitente
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
End With
With Email
.To = Destinatario
.From = Remitente
.Subject = Asunto
.TextBody = Cuerpo
.AddAttachment RutaCompleta
.Configuration.Fields.Update
On Error Resume Next
.Send
End With
If Err.Number = 0 Then
MsgBox "Se enviaron los correos a Tipuanas con Exito", vbInformation, "RODACORP S.A.C"
Else
MsgBox "Se produjo el siguiente error: " & vbNewLine & _
Err.Description, vbCritical, "Error No. " & Err.Number
End If
On Error GoTo 0
Kill RutaCompleta
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
Err:
MsgBox Err.Description, vbCritical + vbOKOnly, Err.Number
End Sub