Snasui Excel Forum

Code: Select all

Sub Notes_Email_Excel_Cells()

    Dim NSession As Object
    Dim NDatabase As Object
    Dim NUIWorkSpace As Object
    Dim NDoc As Object
    Dim NUIdoc As Object
    Dim Attachment1 As String
    Dim Attachment2 As String
    Dim AttachME As Object
    Dim EmbedObj1 As Object
    
    Set NSession = CreateObject("Notes.NotesSession")
    Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
    Set NDatabase = NSession.GetDatabase("", "")
    
    If Not NDatabase.IsOpen Then
        NDatabase.OPENMAIL
    End If
            
    
    'Create a new document
        
    Set NDoc = NDatabase.CreateDocument
        
    With NDoc
        .SendTo = Range("P6:P11").Value       'CHANGE THIS
        .CopyTo = Range("P12:P20").Value
        .Subject = Range("P4").Value
      
        
        NDoc.SAVEMESSAGEONSEND = True
        Attachment1 = Range("P5")
        Attachment2 = Range("Q5")
        If Attachment1 <> "" Then
        On Error Resume Next
        Set AttachME = NDoc.CREATERICHTEXTITEM("attachment1")
        Set EmbedObj1 = AttachME.EMBEDOBJECT(1454, "attachment1", Range("P5"), "") 'Required File Name
       On Error Resume Next
       End If
       
       If Attachment2 <> "" Then
        On Error Resume Next
        Set AttachME = NDoc.CREATERICHTEXTITEM("attachment2")
        Set EmbedObj1 = AttachME.EMBEDOBJECT(1454, "attachment2", Range("Q5"), "") 'Required File Name
       On Error Resume Next
       End If
        'Email body text, including marker text which will be replaced by the Excel cells
        
        .body = Range("B4").Value & vbCr & vbCr & Range("B4:E15").Value
                
                              
            
        .Save True, False
    End With
    
    'Edit the just-created document to copy and paste the Excel cells into it
    
    Set NUIdoc = NUIWorkSpace.EDITDocument(True, NDoc)

    With NUIdoc
        
        'Find the marker text in the Body item
        
        .GotoField ("Body")
    '   .FINDSTRING "**PASTE EXCEL CELLS HERE**"
        '.DESELECTALL            'Uncomment to leave the marker text in place (cells are inserted immediately before)
        
        'Replace it with the Excel cells
        
        Sheets("SendMail").Range("A4:J15").Copy       'CHANGE THIS
        .Paste
        Application.CutCopyMode = False
        
                
        NDoc.PostedDate = Now()
        On Error GoTo errorhandler1
        NDoc.Send 1, Recipient
        
        Set NSession = Nothing
        Set AttachME = Nothing
        Set EmbedObj1 = Nothing
        Set NDoc = Nothing
    End With
    
errorhandler1:
    
    Set NSession = Nothing
    Set AttachME = Nothing
    Set EmbedObj1 = Nothing
    Set NDoc = Nothing
    
    
End Sub