le code du bouton est celui-ci:
- Code : Tout sélectionner
Sub Click(Source As Button)
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim rt As String
Dim sUNID As String
Dim filepath As String
Dim rtitemBody As NotesRichTextItem
Set uidoc =ws.CurrentDocument
Set doc=uidoc.Document
sUNID = doc.UniversalID
Set db = doc.ParentDatabase
Call uidoc.Save 'pour récupérer le Body
Set rtitemBody = doc.GetFirstItem("Body")
filepath=GetSingleFileName("Sélection de pièces jointes","*.*")
If addAttachmentToRichTextField(doc,rtitemBody,filePath) Then
Call uidoc.Close(True)
Delete doc
Set doc = db.GetDocumentByUNID(sUNID)
If Not doc Is Nothing Then
Call ws.EditDocument( False , doc,True)
End If
End If
End Sub
Ici la fonction addAttachementToRichTextField:
- Code : Tout sélectionner
Function addAttachmentToRichTextField(doc As NotesDocument,rtitem As NotesRichTextItem,filePath As String) _
As Boolean
addAttachmentToRichTextField=False
'Dim rtItem As NotesRichTextItem
On Error Goto errHandler
uidoc.Refresh True
Call rtitem.EmbedObject ( EMBED_ATTACHMENT, "", filePath)
Call doc.Save( True, False )
addAttachmentToRichTextField=True
Exit Function
errHandler:
Print "Error" & Error & " occured on line " & Cstr(Erl) & " with error number " _
& Cstr(Err) & " in Method ""addAttachmentToRichTextField"" "
Msgbox "Error " & Error & " occured on line " & Cstr(Erl) & " with error number " _
& Cstr(Err) & " in Method ""addAttachmentToRichTextField"" "
Exit Function
End Function
La pj est insérée mais le doc est non modifiable par la suite.
Merci de votre aide!
cdt
