lunes, 29 de agosto de 2011

Ejemplo para enviar rango de datos como imagen en cuerpo de Email.

Envío un ejemplo con código, para poder enviar un rango de datos de una hoja excel como imagen en el cuerpo de un email.  Esto es de utilidad para generar autorizaciones o reportes donde no sea fácil modificar luego los datos o para realizar mejores presentaciones de reportes o tablas. Espero que les sea de utilidad. Utiliza el Outlook y el mismo debe de estar abierto.
Mando link con ejemplo.
<<Click Acá para bajar ejemplo / Click here to download example>>

Saludos.
CODIGO CORREGIDO. AHORA FUNCIONA OK.!!



Sub Info()
'cuando el mensaje se muestra pareciera que no muestra las imágenes, pero luego las muestra bien.
'When the message is displayed it will look like
'its not embedded correctly, but when Outlook sends the
'message it will embedd it and link the proper source cid.
'
' Must set a reference to Microsoft Outlook ## Object Library to use this:
'

    Dim wks         As Worksheet
    Dim chtObj        As ChartObject
    Dim imgobj As Shape
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 

 
 
    Dim TempFile        As String
 

 Crea_Chart
' Email section
' Email section
    Set wks = Sheets("Graph")
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
 
    If wks.ChartObjects.Count > 0 Then
      For Each chtObj In wks.ChartObjects
        imgfile = Left(TempFile, Len(TempFile) - 4) & chtObj.ZOrder & ".png"
        nombre1 = Format(Now, "dd-mm-yy h-mm-ss") & chtObj.ZOrder & ".png"
        chtObj.Chart.Export Filename:=imgfile, FilterName:="png"
      Next chtObj
    End If
    'create new Outlook MailItem
    Set oApp = CreateObject("Outlook.Application")
    Set oEmail = oApp.CreateItem(olMailItem)
    oEmail.To = ""
    Rem imgfile = "c:\tmp.jpg"
    'add graphic as attachment to Outlook message
    'change path to graphic as needed
    'change the src property to 'cid:your picture filename'
    'it will be changed to the correct cid when its sent.
'    oEmail.HTMLBody = "<BODY><FONT face=Arial color=#000080 size=2></FONT>" &
    oEmail.Attachments.Add(imgfile).Displayname = "Check this out"

 
 
    oEmail.HTMLBody = "<BODY>" & "<IMG alt='' hspace=0 src='cid:" & nombre1 & "' align=baseline border=0>&nbsp;</BODY>"
    oEmail.Save
    oEmail.Display 'fill in the To, Subject, and Send. Or program it in.
    Rem oEmail.Send
    Set oEmail = Nothing
    Set oApp = Nothing

    Set chtObj = Nothing
    Set wks = Nothing
    borra_chart
End Sub

Sub copiar()
'
' Macro1 Macro
' Macro grabada el 29/08/2011 por rapeceche
'
rango = Worksheets("datos").Cells(1, 4)
Range(rango).CopyPicture Appearance:=xlScreen, Format:=xlPicture

'
End Sub
Sub Crea_Chart()
'
' Crea_Chart Macro
' Macro grabada el 29/08/2011 por rapeceche
'

'
    Charts.Add
    ActiveChart.ChartType = xlPie
    ActiveChart.SetSourceData Source:=Sheets("Graph").Range("A1")
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Graph"
    ActiveChart.HasLegend = False
    ActiveSheet.Shapes(1).ScaleWidth 1.5, msoFalse, _
        msoScaleFromBottomRight
    ActiveSheet.Shapes(1).ScaleHeight 1.49, msoFalse, _
        msoScaleFromBottomRight
    ActiveSheet.Shapes(1).ScaleWidth 1.3, msoFalse, msoScaleFromTopLeft
    ActiveSheet.Shapes(1).ScaleHeight 1.3, msoFalse, _
        msoScaleFromTopLeft
    Sheets("logo").Select
    ActiveSheet.Shapes("logo").Select
    Selection.Copy
    Sheets("Graph").Select
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.Paste
 
    Sheets("datos").Select
    copiar
    Sheets("Graph").Select
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.Paste
    Selection.ShapeRange.IncrementTop 113.25
 
    ActiveChart.ChartArea.Select
    With Selection.Border
        .Weight = 2
        .LineStyle = 0
    End With
    Selection.Interior.ColorIndex = xlAutomatic
    Sheets("Graph").DrawingObjects(1).RoundedCorners = False
    Sheets("Graph").DrawingObjects(1).Shadow = False
End Sub
Sub borra_chart()
'
' Macro4 Macro
' Macro grabada el 29/08/2011 por rapeceche
'

'
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.ChartArea.Select
    ActiveWindow.Visible = False
    Selection.Delete
    Range("A1").Select
End Sub



Nota: parte del código lo encontré aca : http://www.eggheadcafe.com/community/aspnet/66/10303739/macro-to-email-sheet-as-the-body-that-includes-objects-not-just-cells.aspx

2 comentarios:

Rodrigo García dijo...

El código posee un error, ya que el receptor no puede ver las imágenes. Perdón.

Rodrigo García dijo...

El código está corregido. Prueben y me avisan.