Código para enviar mail con adjunto y rango de celdas
publicado
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 = "[email protected]; [email protected]"
.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
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
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:
Acá les envío la función llamada RangetoHTML:
' 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