Sending mail via Lotus Notes and displaying a different address

[ericlbt]

Hello,

I use a macro to send emails with an attached picture via Lotus Notes.
The macro is working well but I need to change it so the mail appears to have been sent from a different address than mine.

In a different macro I was able to achieve that by adding the following lines.
They persuade Notes to send/display alternate address
MailDoc.From = "Projet"
MailDoc.SendFrom = "Projet"
MailDoc.DisplayFrom = "Projet"
MailDoc.Principal = "Projet"

I tried to copy those lines after changing "MailDoc" to "UIDoc" but it does't work.

What should I do to update my code to make it work?
Ideally, I would like to be able to send pictures and attach files using the same code.
But the most important is definitively to display a different address.

THANK YOU FOR YOUR HELP.

Here is the code that needs to be modified:

Sub Mail_recap()

Dim MyPic1 As Object
Range("A65000").End(xlUp).Select
Range(Selection, "L1").Select
Set MyPic1 = Selection.SpecialCells(xlCellTypeVisible)

Dim Notes As Object, db As Object, WorkSpace As Object
Dim UIdoc As Object, UserName As String, MailDbName As String
Dim document As Object

Set Notes = CreateObject("Notes.NotesSession")

UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"

'Set db = Notes.GetDataBase(vbNullString, MailDbName)
Set db = Notes.GETDATABASE("", "f45.nsf")

Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.ComposeDocument(, , "Memo")

Set UIdoc = WorkSpace.currentdocument
'Call UIdoc.FieldSetText("SendTo", "elb@test.ch") 'Recipient
Call UIdoc.FieldSetText("EnterSendTo", "elb@test.ch") 'Recipient

Call UIdoc.FieldSetText("Subject", "Recap")

Call UIdoc.GOTOFIELD("Body")
Call UIdoc.INSERTTEXT(WorksheetFunction.Substitute("Hello,@@@", "@", vbCrLf))

MyPic1.Copy: Call UIdoc.Paste

Call UIdoc.INSERTTEXT(String(2, vbCrLf))

Call UIdoc.INSERTTEXT(Application.Substitute("@@@Regards.", "@", vbCrLf))
Application.CutCopyMode = False

'Set document = Maildb.CREATEDOCUMENT

Call UIdoc.Save(True, True)
Call UIdoc.Send(False)

Set docc = UIdoc.document
With docc
.SaveOptions = "0"
End With

Call UIdoc.Close(True)

Set UIdoc = Nothing
Set WorkSpace = Nothing
Set db = Nothing
Set Notes = Nothing

End Sub

 

[John_w]

This macro sends the email with a different sender name and email address. Change the code where indicated.

Public Sub Mail_Recap2()

    Dim Session As Object, MailDb As Object, UIWorkspace As Object
    Dim UIdoc As Object, MailDoc As Object
    Dim UserName As String, MailDbName As String
    Dim rangePic As Range
    
    With ActiveSheet
        Set rangePic = .Range(.Cells(.Rows.Count, "A").End(xlUp), .Range("L1")).SpecialCells(xlCellTypeVisible)
    End With
    
    Set Session = CreateObject("Notes.NotesSession")
    Set UIWorkspace = CreateObject("Notes.NotesUIWorkspace")
            
    UserName = Session.UserName
    MailDbName = Left(UserName, 1) & Right(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
    Set MailDb = Session.GetDatabase("", MailDbName)
    If Not MailDb.IsOpen Then MailDb.OpenMail
    
    UIWorkspace.ComposeDocument , , "Memo"
    Do
        Set UIdoc = UIWorkspace.CurrentDocument
        DoEvents
    Loop While UIdoc Is Nothing
    
    With UIdoc
        .FieldSetText "EnterSendTo", "email.address1@email.com"  'CHANGE THIS
        .FieldSetText "EnterCopyTo", "email.address2@email.com"  'CHANGE THIS
        .FieldSetText "Subject", "Recap"
    
        .GoToField "Body"
    
        .InsertText "Hello,"
        .InsertText vbCrLf
        .InsertText vbCrLf
        .InsertText vbCrLf
    
        rangePic.Copy
        .Paste
        Application.CutCopyMode = False
    
        .InsertText vbCrLf
        .InsertText vbCrLf
        .InsertText "Regards."
    
        .Save True, True
        .Send False
    
        Set MailDoc = .document
    End With
    
    With MailDoc
        .SaveOptions = "0"
    
        'Send with an alternative name and email address
        
        .ReplaceItemValue "From", "Another Name <another.address@email.com@NotesDomain>"  'CHANGE THIS
        .ReplaceItemValue "SendFrom", "Another Name <another.address@email.com@NotesDomain>"  'CHANGE THIS
        .ReplaceItemValue "Principal", "Another Name <another.address@email.com@NotesDomain>"  'CHANGE THIS

        'Send the email and save it in the Sent folder

        .SaveMessageOnSend = True
        .ReplaceItemValue "PostedDate", Now
        .Send False
    End With
    
    UIdoc.Close True
    
    Set UIdoc = Nothing
    Set UIWorkspace = Nothing
    Set MailDb = Nothing
    Set Session = Nothing

End Sub

Note - in the example email address, another.address@email.com@NotesDomain, the @NotesDomain part is required, but I think it can be anything (e.g. @Anything); it might even need to be your actual Notes domain.

 

[ericlbt]

Hi John,

Thank you very much for your code.

For some reason, your code is working too well!

It actually generates 2 mails.
One from my address and one from the "another.address@email.com".

In both cases the content is fine.

I tried to change parts of the code but I didn't succeed to stop the mail sent from my address.

Do you have any suggestions?

Thank you again for your help.

 

[ericlbt]

Hi John,

I have actually been able to find a solution.

I move the MailDoc part of your code higher up.
It does the trick.

I could not have done it without your code.

Thank you.


Public Sub Mail_Recap2()

Dim Session As Object, MailDb As Object, UIWorkspace As Object
Dim UIdoc As Object, MailDoc As Object
Dim UserName As String, MailDbName As String
Dim rangePic As Range
Dim EmbedObj As Object

With ActiveSheet
Set rangePic = .Range(.Cells(.Rows.Count, "A").End(xlUp), .Range("L1")).SpecialCells(xlCellTypeVisible)
End With

Set Session = CreateObject("Notes.NotesSession")
Set UIWorkspace = CreateObject("Notes.NotesUIWorkspace")

UserName = Session.UserName
MailDbName = Left(UserName, 1) & Right(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set MailDb = Session.GetDatabase("", MailDbName)
If Not MailDb.IsOpen Then MailDb.OpenMail

UIWorkspace.ComposeDocument , , "Memo"
Do
Set UIdoc = UIWorkspace.CurrentDocument
DoEvents
Loop While UIdoc Is Nothing

With UIdoc

Set MailDoc = .document
End With

With MailDoc
.saveoptions = "0"

'Send with an alternative name and email address

'.ReplaceItemValue "From", "ProjetReporting Bo-Bourse <projet@mail.com>"
'.ReplaceItemValue "SendFrom", "ProjetReporting Bo-Bourse <projet@mail.com>"
.ReplaceItemValue "Principal", "ProjetReporting Bo-Bourse <projet@mail.com>>"

'Send the email and save it in the Sent folder

.SAVEMESSAGEONSEND = True
.ReplaceItemValue "PostedDate", Now
'.Send False

Set AttachMe = MailDoc.CREATERICHTEXTITEM("attachment1")
Set EmbedObj = AttachMe.EMBEDOBJECT(1454, "attachment1", "\\wpad-p.bcv.ch\Documents_Partages\Devises\SERVICE RECO POS & PNL\ELB\PROJETS\Récap Back & Front - AUTO.xlsb", "")

End With


With UIdoc


.FieldSetText "EnterSendTo", "eric@mail.com"
.FieldSetText "Subject", "Recap"

.GoToField "Body"

.INSERTTEXT "Hello,"
.INSERTTEXT vbCrLf
.INSERTTEXT vbCrLf
.INSERTTEXT vbCrLf

rangePic.Copy
.Paste
Application.CutCopyMode = False

.INSERTTEXT (Application.Substitute("@@@Cordialement.", "@", vbCrLf))

.Save True, True
.Send False

'Send the email and save it in the Sent folder

End With

UIdoc.Close True

Set UIdoc = Nothing
Set UIWorkspace = Nothing
Set MailDb = Nothing
Set Session = Nothing

End Sub

 

[John_w]

Thanks for posting your solution. This should be useful for other people.