Código para enviar mail con adjunto y rango de celdas

pauloc1989 · el 14 de mayo

Amigos,

Estoy nuevamente por acá para que me ayuden con un código:

Lo que estoy haciendo es enviar un mail de Outlook - en su versión 2010 -, mediante una Macro; ésta Macro envía un correo con un archivo adjunto más un rango de celdas específico. Hasta el momento todo bien, pero al momento de cambiar la propiedad Display por send es donde falla, ya que me envía el archivo adjunto pero no el rango de celdas. Les adjunto el código que estoy utilizando:

Sub rangoCeldas()

' Don't forget to copy the function RangetoHTML in the module.

' Working in Office 2000-2010

    Dim rng As Range

    Dim OutApp As Object

    Dim OutMail As Object

    Dim Adjunto As Variant

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    Set rng = Nothing

    On Error Resume Next

    Set rng = Sheets("Hoja1").Range("FE8:FH29").SpecialCells(xlCellTypeVisible)

    On Error GoTo 0

    If rng Is Nothing Then

        MsgBox "La selección no es un rango o la hoja está protegida" & _

              vbNewLine & "Por favor, corrija y vuelva a intentarlo.", vbOKOnly

        Exit Sub

    End If

    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    Adjunto = "C:\Archivo.xlsm"

    On Error Resume Next

    With OutMail

        .Attachments.Add (Adjunto)

        .To = "xxxx@hotmail.com; xxxx@gmail.com"

        .CC = "copia"

        .BCC = ""

        .Subject = "Esta es la línea de asunto"

        .HtmlBody = RangetoHTML(rng)

        .Send  'or use .Display

    End With

    On Error GoTo 0

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

    Set OutMail = Nothing

    Set OutApp = Nothing

End Sub[/CODE]

Acá les envío la función llamada RangetoHTML:

[CODE]Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copia el rango de celdas y crea un nuevo libro...?
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
[/CODE]

Si alguien ve algún error por favoooooooooooooooor ayúdeme.

Saludos desde Chile

Antoni · el 14 de mayo

.

Lo he probado con varios rangos y archivos y no he tenido el mas mínimo problema.

.

pauloc1989 · el 14 de mayo

Gracias por la disponibilidad. Te cuento que me funcionó correctamente sólo con poner send en minúscula, ya que colocaba la primera letra en mayúscula. Cosas de programación!! Gracias de todas maneras amigo!

Seba Carrasco · el 17 de julio

Estimado, sabes que estaba usando tu función, el problema es que cuando uso un rango mayor, digamos Range("A9:P30"), y el archivo no se adjunta, es decir no se carga ni el mensaje ni la imagen. Pero si quito el comando para mostrar solo las celdas visibles, entonecs si lo carga sin problema. Qué podría ser??

pauloc1989 · el 18 de julio

Amigo, adjunto el código que estás utilizando para hacerme una idea de lo que está fallando.

Saludos

Seba Carrasco · el 18 de julio

Pauloc, te comento que estoy usando prácticamente el mismo código que tu, de todas maneras lo adjunto. Muchas gracias por la disposición para ayudarme.

Sub Mail_Selection_Range_Outlook_Body()

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

'Don't forget to copy the function RangetoHTML in the module.

'Working in Excel 2000-2013

    Dim rng As Range

    Dim OutApp As Object

    Dim OutMail As Object


    Dim strto As String

    Dim StrBody As String


    For Each cell In ThisWorkbook.Sheets("Pantalla ingreso datos").Range("N75:N91")

        If cell.Value Like "?*@?*.?*" Then

            strto = strto & cell.Value & ";"

        End If

    Next cell

    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)


    StrBody = "Se envía el resultado de la auditoría de nivel de calidad realizada a Procesos Complementarios" & "" & "<br><br><br>"



    Set rng = Nothing

    On Error Resume Next

    'Only the visible cells in the selection

    'Set rng = Selection.SpecialCells(xlCellTypeVisible)

    'You can also use a fixed range if you want

    Set rng = Sheets("Pantalla ingreso datos").Range("A9:Q32").SpecialCells(xlCellTypeVisible)

    On Error GoTo 0


    If rng Is Nothing Then

        MsgBox "The selection is not a range or the sheet is protected" & _

              vbNewLine & "please correct and try again.", vbOKOnly

        Exit Sub

    End If


    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With


    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next

    With OutMail

        .To = strto

        .CC = ""

        .BCC = ""

        .Subject = "Auditoría de Nivel de Calidad de Procesos Complementarios"

        .HTMLBody = StrBody & RangetoHTML(rng)

        .Display  'or use .Display

    End With

    On Error GoTo 0


    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With


    Set OutMail = Nothing

    Set OutApp = Nothing

End Sub[/CODE]

[CODE]
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

[/CODE]