Como pegar varias imagenes con correo de outlook con macro

[Gustavo Piedra]

Necesito poner varias imagenes en el cuerpo de un correo de outlook, las imagenes estan en archivos diferentes .pgn ya guardados anteriormente...

Ya tengo el codigo para crear el correo...

En espera de sus cometarios

[logroastur]

Buenas chequea archivo

Deberás descargar los dos archivos pero solo es preciso descomprimir el archivo SendMailOutlook.part1.rar

Lo que debes de hacer es colocar el texto en un archivo word y sus imagenes, como esta el archivo de ejemplo

Un saludo

SendMailOutlook.part1.rar

SendMailOutlook.part2.rar

[Gustavo Piedra]

No he podido descargar los archivos, tengo este codigo para crear el correo pero solo pega una imagen, y al momento que trato de poner otra me la adjunta..

si es posible que sean con las imagenes ya guradadas en .png?? ya que dentro de la macro tengo otro intruccion para que cuando vaya generando las imagenes de una hojas de excel del mismo reporte..

Una disculpa por las molestias ocacionadas..

Public Sub correo()

ruta = ActiveWorkbook.Path

Dim myOLApp

Dim myOLItem

Set myOLApp = CreateObject("Outlook.Application")

Set myOLItem = myOLApp.CreateItem(olMailItem)

'fichero = direccion & ActiveWorkbook.Name

With myOLItem

.To = destinatarios1

.cc = destinatarios2

.Subject = "Titulo del correo"

.attachments.Add ruta & "\Imagene.png"

Filename = ruta & "\Imagene.png"

'.attachments.Add ruta & "\Imagenes2.png"

.HTMLBody = "<img src='cid:'" & .attachments.Item(1).Filename & "'' height=900 width=1200>"

.display

End With

Set myOLApp = Nothing

Set myOLItem = Nothing

End Sub

[logroastur]

Bien otra forma es adjuntar directamente las imagenes sin necesidad de usar archivo de Word

Bien utiliza el siguiente código

Sub AdImagenBody()
    Dim i               As Integer
    Dim j               As Integer
    Dim archivos        As Variant
    Dim carpeta         As String
    Dim fichero         As String
    Dim tipo            As String
    Dim tBody           As String
    Dim destino1       As String
    Dim destino2    As String
    Dim destino3    As String
    Dim titulo          As String

    Dim obj             As Object
    Dim iDm             As Object
    Dim adjuntos        As Object
    Dim adjunto         As Object

    Dim oSession        As Object
    Dim oMsg            As Object
    Dim oAdjuntos       As Object
    Dim oAdjunto        As Object
    Dim nlFields        As Object
    Dim oField          As Object

    Dim nID             As String

    Const CdoPR_ATTACH_MIME_TAG = &H370E001E
    Const raiz          As String = "image/"

    carpeta = ThisWorkbook.Path      '----> Path Carpeta donde se ubican las imagenes
    If Right(carpeta, 1) <> Application.PathSeparator Then carpeta = carpeta & Application.PathSeparator
    archivos = Array()               '----> Nombre de los archivos con la extensión, entre comillas y separados por una coma
    destino1 = ""                    '----> Nombres de los destinatarios del email, se deben de separar con ;
    destino2 = ""                    '----> Nombres de los destinatarios que se envia copia del email, se deben de separar con ;
    destino3 = ""                    '----> Nombres de los destinatarios que se envia copia oculta del email, se deben de separar con ;
    titulo = ""

    Set obj = CreateObject("Outlook.Application")
        Set iDm = obj.CreateItem(0)
        Set adjuntos = iDm.Attachments
        For i = LBound(archivos) To UBound(archivos)
            fichero = carpeta & archivos(i)
            Set adjunto = adjuntos.Add(fichero)
        Next i
        iDm.Close 0
        nID = iDm.EntryID
        Set iDm = Nothing
        Set adjuntos = Nothing
        Set adjunto = Nothing

    Set oSession = CreateObject("MAPI.Session")
        oSession.Logon "", "", False, False
        Set oMsg = oSession.GetMessage(nID)
        Set oAdjuntos = oMsg.Attachments
        For i = 1 To oAdjuntos.Count
            fichero = archivos(i - 1)
            Set oAdjunto = oAdjuntos.Item(i)
            Set nlFields = oAdjunto.Fields
            j = InStrRev(fichero, ".")
            tipo = Right(fichero, Len(fichero) - j)
            tipo = raiz & tipo
            Set oField = nlFields.Add(CdoPR_ATTACH_MIME_TAG, tipo)
            Set oField = nlFields.Add(&H3712001E, fichero)
            tBody = tBody & "<IMG align=baseline border=0 hspace=0 src=cid:" & fichero & " alt=" & fichero & ">"
            oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
            oMsg.Update
            Set oAdjunto = Nothing
            Set nlFields = Nothing
            Set oField = Nothing
            Set oField = Nothing
        Next i

    Set iDm = obj.GetNamespace("MAPI").GetItemFromID(nID)
        With iDm
            .To = destinatario1
            .CC = destinatario2
            .BCC = destinatario3
            .Subject = titulo
            .HTMLBody = tBody
            .Close (0)
            .Display
        End With
    Set oField = Nothing
    Set nlFields = Nothing
    Set oMsg = Nothing
    oSession.Logoff
    Set oSession = Nothing
    Set obj = Nothing
    Set iDm = Nothing
End Sub

Un saludo

[Gustavo Piedra]

gracias por la ayuda..

he tenido muchos probemas con este secmento del codigo ya que no se como funciona y si corro asi la macro me genera un error en esta linea de codigo. Set oSession = CreateObject("MAPI.Session"), a lo que estuve investigando por otro lado sirve para validar que este abierto un correo, el correo siempre esta abierto habra forma de omitir esta parte del codigo, ya que si solo lo quito me marca muchos errores..

Set oSession = CreateObject("MAPI.Session")

oSession.Logon "", "", False, False

Set oMsg = oSession.GetMessage(nID)

Set oAdjuntos = oMsg.Attachments

Saludos

[logroastur]

Buenas veamos seria conveniente que indicases que error te genera, es decir que me indiques el testo que te muestra en el mensaje del error.

Aventurando supongo que sera que no posees el control activex CDO versión 1.21 bien si fuese asi puedes reaziar la descarga desde el lugar de descargas microsft

Data Object

Bien si fuese esto realiza la descarga e instalación y prueba de nuevo

Un saludo