Envia HTML Mail com Anexo aberto no corpo do e-mail

Sub Initialize

On Error Goto trataerro


Dim session As New notessession
Dim db As notesdatabase
Dim coll As notesdocumentcollection
Dim visao As NotesView
Dim docmail As NotesDocument
Dim docLogo As NotesDocument

Dim rtitem As Variant
Dim filename As Variant
Dim filepath As String
Dim filesname As String
Dim sizeInBytes As Long

Dim notesEmbeddedObject As NotesEmbeddedObject

Set db = session.currentdatabase
'seta o doc p/envio
Set docmail = New NotesDocument(db)


Dim mimeRoot As NotesMimeEntity, mime As NotesMimeEntity
Dim header As NotesMimeHeader
Dim stream As NotesStream
session.ConvertMIME = False ' Do not convert MIME to rich text
Set stream = session.CreateStream()

' Create main MIME message
Set stream = session.CreateStream
Set MIMERoot = docmail.CreateMIMEEntity ' message root

' Create child entities
Set mime = MIMERoot.CreateChildEntity
Set header = MIMERoot.getNthHeader("Content-Type")
Call header.SetHeaderVal("multipart/related")

'seta o path default
filepath = "D:\Diretorio\"

'//seta a visão
Set visao = db.getView("vwLogo")
'//seta o doc. com a imagem a ser anexada no e-mail
Set docLogo = visao.getDocumentByKey("img_LOGO.JPG", True)
'verifica se o documento foi setado corretamente
If docLogo Is Nothing Then
Msgbox "Documento com a imagem não foi encontrado",16,"Operação Cancelada"
Exit Sub
End If

'//seta o nome do anexo
filename = docLogo.ASName(0) ' //ca_labelAnexo

'seta o anexo
Set notesEmbeddedObject = docLogo.GetAttachment( filename )
'verifica se o anexo foi setado corretamente
If notesEmbeddedObject Is Nothing Then
Msgbox "Imagem não encontrada",16,"Operação Cancelada"
Exit Sub
End If
'extrai o anexo
Call notesEmbeddedObject.ExtractFile( filepath & filename )

' Create Message
Call stream.WriteText(|| &_ || & _ |

| & |1. Imagem => | & |

| & Oribody & |

| & _ |

| )
Call mime.SetContentFromText(stream,"text/html",ENC_NONE)
Call stream.Close

' Create inline image reference
Set mime = MIMERoot.CreateChildEntity
'Call stream.Open(filepath & filename )

If Not stream.Open(filepath & filename ) Then
Msgbox "Open failed"
Exit Sub
End If
If stream.Bytes = 0 Then
Msgbox "File has no content"
Exit Sub
End If


Call mime.SetContentFromBytes(stream, "image/jpeg",ENC_NONE)
Call stream.Close
Call mime.EncodeContent(ENC_BASE64)
Set header = mime.CreateHeader("Content-ID")
Call header.SetHeaderVal("")

Call docmail.Send(False, "DESTINATARIO")
' Call docmail.Send(false
session.ConvertMIME = True ' Restore conversion


Exit Sub
trataerro:
Msgbox "Error - Linha: " & Cstr(Erl) & " Tipo: "&Cstr(Error) & " " & Cstr(Error)
Exit Sub
End Sub