Bom dia!!!

Veja se isso pode te ajudar.

Option Explicit 
 
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ 
(ByVal lpClassName As String, _ 
ByVal lpWindowName As String) As Long 
 
Sub Lotus_Formatted_Range_Into_Body() 
    Dim oWorkSpace As Object, oUIDoc As Object 
    Dim stTo As String, stCC As String, stSubject As String, stBody As String 
    Dim rnBody As Range 
    Dim lnRetVal As Long 
     
     'Lotus Notes must be running in order to get the Paste-function to work properly...
     'Although the body has the focus it will not paste from the clip-board.
     'Even if no formhead are in use it will not work.
     
    lnRetVal = FindWindow("NOTES", vbNullString) 
     
    If lnRetVal = 0 Then 
        MsgBox "Lotus Notes must be open in order to execute this procedure.", vbInformation, "Systemerror - Lotus Notus" 
        Exit Sub 
    End If 
     
    Application.ScreenUpdating = False 
     
    Set oWorkSpace = CreateObject("Notes.NotesUIWorkspace") 
     
    stTo = "anyaddress@address.com" 
    stCC = "anyaddress@address.com" 
    stSubject = "Subject of the Message" 
     'stBody = "This shows up in the Message Body"
     
     'In the active sheet a named range is used
    Set rnBody = ActiveSheet.Range("under") 
    rnBody.Copy 
     
    On Error Resume Next 
     'The error-message "Unable to find Window" is a known bug and it generate different
     'error-messages depending on which version (4.x / 5.x) that´s running.
     'Make sure You have open the view "Post" and the use the command
     'File | Database | Properties to find both the server and the maildatabase.
     'Here are my settings without any Domino-server.
    Set oUIDoc = oWorkSpace.COMPOSEDOCUMENT("Server_Name", "Database_Name.nsf", "Memo") 
    On Error Goto 0 
     
    Set oUIDoc = oWorkSpace.CurrentDocument 
     
    Call oUIDoc.FIELDSETTEXT("EnterSendTo", stTo) 
    Call oUIDoc.FIELDSETTEXT("EnterCopyTo", stCC) 
    Call oUIDoc.FIELDSETTEXT("Subject", stSubject) 
     'Call oUIDoc.FieldSetText("Body", stBody)
    Call oUIDoc.GoToField("Body") 
    Call oUIDoc.Paste 
     
    Call oUIDoc.Send(False) 
    Call oUIDoc.Save(True, False, False) 
    Call oUIDoc.Close 
     
    Set oUIDoc = Nothing 
     
    With Application 
        .CutCopyMode = False 
        .ScreenUpdating = True 
    End With 
     
    MsgBox "O E-mail deve ser criado, salvado mas não enviado", vbInformation 
     
    AppActivate "Notes" 
End Sub 

Obrigado pela sugestão, mas não estou conseguindo pegar o caminho do servidor o mesmo retorna erro.....

Set oUIDoc = oWorkSpace.COMPOSEDOCUMENT("Server_Name", "Database_Name.nsf", "Memo")

tentei por o caminho no database_names que eo meu caso mas não foi...
Vou ver se consigo utilzar o processo do outro codigo junto com este...
Vamos ver o que vai dar...

Boa tarde!!!

geroeane, tente adaptar os códigos..qualquer coisa retorne ao fórum.

Att..

Consegui em partes falta dar uma lapidada em uma parte do codigo. Este ficou assim :

Dim objNotesSession As Object
Dim objNotesMailFile As Object
Dim objNotesDocument As Object
Dim objNotesField As Object

Function SendMail()

On Error GoTo SendMailError

EMailSendTo = "geronimo_andrzejewski@embraco.com" '' Required - Send to address
EMailCCTo = ""                      '' Optional
EMailBCCTo = ""                     '' Optional
EmailSubject = "Visões de Custos"


''Establish Connection to Notes
Set objNotesSession = CreateObject("Notes.NotesSession")

''Establish Connection to Mail File
''                                    .GETDATABASE("SERVER", "FILE")
Set objNotesMailFile = objNotesSession.GetDatabase("", "")
''Open Mail
objNotesMailFile.OPENMAIL

''Create New Memo
Set objNotesDocument = objNotesMailFile.CreateDocument

''Create 'Subject Field'
Set objNotesField = objNotesDocument.AppendItemValue("Subject", EmailSubject)

''Create 'Send To' Field
Set objNotesField = objNotesDocument.AppendItemValue("SendTo", EMailSendTo)

''Create 'Copy To' Field
Set objNotesField = objNotesDocument.AppendItemValue("CopyTo", EMailCCTo)

''Create 'Blind Copy To' Field
Set objNotesField = objNotesDocument.AppendItemValue("BlindCopyTo", EMailBCCTo)

''Create 'Body' of memo
Set objNotesField = objNotesDocument.CreateRichTextItem("Body")

With objNotesField
    
    .AppendText = "Bom Dia"
    .AddNewLine 1
    .AppendText "Segue planilha com os Codigos para Cadastrar as Visões de Custos."
    .AddNewLine 2
    .AppendText Cells(1, 1).Value & "______"
    .AppendText Cells(1, 2).Value
    .AddNewLine 3
    .AppendText Cells(2, 1).Value & "______"
    .AppendText Cells(2, 2).Value   
    .AddNewLine 4
    .AddNewLine 5
    .AppendText "Desde ja agradeço a atenção."
End With


'Anexar planilha no email --- 1454 indica um anexo de arquivo
''objNotesField = objNotesField.EMBEDOBJECT(1454, "", "C:Temptest.xls")
'objNotesField = objNotesField.EmbedObject(1454, "", ActiveWorkbook.FullName)


''Enviar o emaill
objNotesDocument.Send (0)

''Release storage
Set objNotesSession = Nothing
Set bjNotesSession = Nothing
Set objNotesMailFile = Nothing
Set objNotesDocument = Nothing
Set objNotesField = Nothing

''Set return code
SendMail = True

Exit Function

SendMailError:
Msg = "Error # " & Str(Err.Number) & " was generated by " _
           & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext

SendMail = False

End Function

Esta parte do codigo abaixo é que falta lapidar :

.AppendText Cells(1, 1).Value & "______"
    .AppendText Cells(1, 2).Value
    .AddNewLine 3
    .AppendText Cells(2, 1).Value & "______"
    .AppendText Cells(2, 2).Value

Em vez de separar as colunas pelo traço sera que poderiamos dar um TAB entre elas.