Sub SendMail()



On Error GoTo Ett_Trap



    Dim nDB As Object

    Dim nDoc As Object

    Dim nSession As Object

    Dim nRichTextItem As Object

    Dim nRichTemItem2 As Object

    Dim nAttachment As Object

    Dim nPicture As Object

    Dim strTo As String

    Dim strCC As String

    Dim strBCC As String

    Dim strAttachment As String

    Dim strPicture As String

    Dim ws As NOTESUIWORKSPACE

    Dim uidoc As Object



'Fill Body of Email

    strSubject = txtCustName.Text & " " & txtCustNo.Text

    

'Attachments

    strAttachment = ActiveWorkbook.FullName

    

'Copy Screen

    Sheet4.Range("A1:P23").CopyPicture xlScreen, xlBitmap



'Call Lotus Notes

    Set nSession = CreateObject("Notes.Notessession")

    Set nDB = nSession.GetDatabase("", "")

    Call nDB.OPENMAIL

    Set nDoc = nDB.CreateDocument

    

'Add Attachemnt file to email if passed

    Set nRichTextItem = nDoc.CreateRichTextItem("Attachment")

    Set nAttachment = nRichTextItem.EmbedObject(EMBED_ATTACHMENT, "", strAttachment)

    

'Paste Picture

    Set uidoc = ws.EDITDOCUMENT

    Call uidoc.GOTOFIELD("body")

    Call uidoc.Paste

        

'Set Values of Email

    Call nDoc.ReplaceItemValue("Subject", strSubject)



'Call nDoc.Send(False) 'Comment to not send email and save to drafts

    'Call nDoc.Save(True, True)

     'Call nDoc.Save(False, False)

     Set nDoc = Nothing



Ett_Trap_Exit:

    Exit Sub

    

Ett_Trap:

    MsgBox Err.Description

    Resume Ett_Trap_Exit



End Sub