Mail via Lotus Notes avec adresse d'envoi "modifiée"
Bonjour,
La macro ci-dessous me permet d'attacher une "photo" de mon fichier Excel dans Lotus Notes.
Elle fonctionne correctement mais 'aimerais la modifier pour que que le nom de l'émetteur soit différent.
Aujourd'hui c'est mon adresse qui apparaît. Je souhaite que ce soit une autre adresse.
Dans une autre macro, qui attache un fichier au mail Lotus Notes, j'y suis arrivé en ajoutant les lignes suivantes:
MailDoc.From = "Projet" 'Sent by"
MailDoc.SendFrom = "Projet" 'Sent by E-Mail Address on REPLY"
MailDoc.DisplayFrom = "Projet" 'Group Email Display Name"
MailDoc.Principal = "Projet" 'Group Email Address on REPLY"
Cela fonctionne parfaitement.
Pour les destinataires le message a été envoyé par "Projet" et leur réponse est envoyée à "Projet".
Pourtant Je n'arrive pas à adapter ces 4 lignes dans la macro ci-dessous.
J'ai modifié "MailDoc" en "UIDoc" mais sans succès.
Merci par avance pour vos commentaires.
Sub SendMail()
Dim MyPic1 As Object
Range("A65000").End(xlUp).Select
Range(Selection, "L1").Select
Dim MyPic1 As Object
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("", "f45.nsf")
Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.ComposeDocument(, , "Memo")
Set UIdoc = WorkSpace.currentdocument
Call UIdoc.FieldSetText("EnterSendTo", "eric@mail.com") 'Recipient
Call UIdoc.FieldSetText("Subject", "Récap")
Call UIdoc.GOTOFIELD("Body")
Call UIdoc.INSERTTEXT(WorksheetFunction.Substitute("Bonjour,@@@", "@", vbCrLf))
MyPic1.Copy: Call UIdoc.Paste
Call UIdoc.INSERTTEXT(String(2, vbCrLf))
Call UIdoc.INSERTTEXT(Application.Substitute("@@@Cordialement.", "@", vbCrLf))
Application.CutCopyMode = False
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
Slt ericlbt,
essaie comme ca peut être
Call WorkSpace.AppendItemValue("From", "Projet")
Call WorkSpace.AppendItemValue("SendFrom", "Projet")
Call WorkSpace.AppendItemValue("DisplayFrom", "Projet")
Call WorkSpace.AppendItemValue("Principal", "Projet")aprés le Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Bonjour m3ellem1,
Merci pour le code mais malheureusement cela ne fonctionne pas.
Peu importe l'endroit où je le copie j'ai toujours le même message d'erreur.
Erreur d'exécution '438':
Propriété ou méthode non gérée par cet objet.
encore un essai
Call UIdoc.AppendItemValue("From", "Projet")
Call UIdoc.AppendItemValue("SendFrom", "Projet")
Call UIdoc.AppendItemValue("DisplayFrom", "Projet")
Call UIdoc.AppendItemValue("Principal", "Projet")Merci pour la nouvelle suggestion.
En fait j'avais aussi essayé cette approche.
J'a repris une ancienne macro que j'ai modifiée et tout fonctionne.
Merci d'avoir pris le temps de me répondre.
En cas d'intérêt, la voici mon nouveau code:
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", "Projet <projet@mail.com>"
'.ReplaceItemValue "SendFrom", "Projet <projet@mail.com>"
.ReplaceItemValue "Principal", "Projet <projet@mail.com>"
'Send the email and save it in the Sent folder
.SAVEMESSAGEONSEND = True
.ReplaceItemValue "PostedDate", Now
'.Send False
End With
With UIdoc
.FieldSetText "EnterSendTo", "eric@mail.com"
.FieldSetText "Subject", "Recap"
.GoToField "Body"
.INSERTTEXT "Bonjour,"
.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
Merci pour ton retour ericlbt
Bonjour m3ellem1,
Merci beaucoup pour votre réponse rapide, c'est très gentil de votre part.
Toutefois, je n'ai pas réussi à utiliser les différents codes pour les adapter à mon fichier et mon besoin.
Je serai très reconnaissant si vous arrivez à m'aider en incorporant l'un des codes à mon fichier en pièce jointe.
Merci beaucoup encore une fois