DominoArea.org [Archive]

Ce tips à pour objet d'ajouter une action au menu outils dans les vues d'une mailbox pour supprimer d'un coup tous les fichiers attachés des mémos sélectionnés sans avoir donc à ouvrir chaque mémo et supprimer les fichiers attachés.

Créer une action partagée nommé : "Outils\Supprimer les fichiers attachés", choisissez le language Lotuscript et dans l'évènement Click copier/coller le code ci-après.

Code : Tout sélectionner

Sub Click(Source As Button)
   Dim ws As New NotesUIWorkspace
   Dim db As NotesDatabase
   Dim view As NotesUIView
   Dim docs As NotesDocumentCollection
   Dim doc As NotesDocument
   Dim rtitem As Variant
   Dim askme As Integer
   Dim user As NotesName
   Dim rtnav As NotesRichTextNavigator
   Dim onav As NotesEmbeddedObject
   On Error Goto Errors
   askme = ws.Prompt (PROMPT_YESNO,"Supprimer les fichiers attachés", "Vous êtes sur le point de supprimer tous les fichiers attachés des documents sélectionnés, voulez-vous vraiment continuer ?")
   If askme = 1 Then
      Set db = ws.CurrentDatabase.Database
      Set view = ws.CurrentView
      If Not( db Is Nothing ) Then
         Set docs = db.Unprocesseddocuments
         If Not( docs Is Nothing ) Then
            If( docs.Count > 0 ) Then
               Set user = New NotesName(db.Parent.UserName)
               Set doc = docs.GetFirstDocument()
               While Not( doc Is Nothing )
                  Set rtitem = doc.GetFirstItem( "Body" )
                  If Not( rtitem Is Nothing ) Then
                     If ( rtitem.Type = RICHTEXT ) Then
                        If( Isarray(rtitem.EmbeddedObjects) ) Then
                           Set rtnav = rtitem.CreateNavigator
                           Forall o In rtitem.EmbeddedObjects
                              If ( o.Type = EMBED_ATTACHMENT ) Then
                                 Set onav = rtnav.GetFirstElement(RTELEM_TYPE_FILEATTACHMENT)
                                 If Not( onav Is Nothing ) Then
                                    Call rtnav.SetPosition(onav)
                                    Call rtitem.BeginInsert(rtnav)
                                    Call rtitem.Appendtext(|[attachement "|+onav.Name+|" supprimé par |+user.Abbreviated+|]|)
                                    Call rtitem.EndInsert()
                                    Call o.Remove()
                                    Call rtitem.Update()
                                 End If
                              End If
                           End Forall
                           Call doc.Save( True, True )
                        End If
                     End If
                     Set rtitem = Nothing
                  End If
                  Set doc = docs.GetNextDocument(doc)
               Wend
               If Not( view Is Nothing ) Then
                  Call view.DeselectAll()
               End If
               Call ws.ViewRefresh()
            End If
         End If
      End If
   End If
   
ExitSub:
   Exit Sub
   
Errors:
   Dim errmsg As String
   errmsg = "(Error #: " & Str(Err) & ") " & Error$
   Print errmsg
   Resume Next
End Sub


Vous n'avez plus qu'à insérer l'action partagée dans les vues de votre mailbox.

L'utilisateur pourra alors sélectionner un ensemble de mémo et lancer l'action à partir du bouton Outils.

Vous pouvez en faire une variante pour proposer à l'utilisateur de sauvegarder d'abord les fichiers attachés dans un répertoire de son choix.

je crois savoir ce qu'il manque
avant le Forall o In rtitem.EmbeddedObjects
il faut en premier lieu vérfier que l'on a bien un tableau d'objets
donc un petit
if not isEmpty(rtitem.EmbeddedObjects) then


et à l'intérieur du test on place les traitement




end if

c'est le piège classique et malheureusement pas très documenté

le test isArray prélable n'est pas suffisant et le test que je préconise il vaut mieux le mettre avant le test sur le isArray qui pour moi pourrait être supprimé car ça plante déjà à ce niveau étant donné que l'objet n'est pas instancié

Alors: voici enfin le résultat qui fonctionne. je pose le code pour les gens comme moi qui chercherait à détacher massivement les pièces jointes dans les messages d'une boite aux lettres, les déposer dans un répertoire réseau, et supprimer la pièce jointe en question. Ce code fonctionne sur un client V8.5
il suffit de coller ce code dans initialize, et modifier le chemin réseau de votre répertoire

Code : Tout sélectionner

Sub initialize
Dim session As New NotesSession
Dim db As NotesDatabase
Dim docs As NotesDocumentCollection
Dim doc As NotesDocument
Dim rtitem As Variant

On Error Goto erreur

Set db = session.CurrentDatabase

If Not( db Is Nothing ) Then
Set docs = db.UnprocessedDocuments
If Not( docs Is Nothing ) Then
If( docs.Count > 0 ) Then
Set doc = docs.GetFirstDocument()
While Not( doc Is Nothing )
Set rtitem = doc.GetFirstItem( "Body" )
If Not rtitem Is Nothing Then
If ( rtitem.Type = RICHTEXT ) Then
If Not Isempty(rtitem.EmbeddedObjects) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Call o.ExtractFile _
( "\\serveur\partage\repertoire\" +o.Name)
Call o.Remove
Call doc.save(True,True)
End If
End Forall
End If
End If
End If
Set rtitem = Nothing
Set doc = docs.GetNextDocument(doc)
Wend
End If
End If
End If

Exit Sub
erreur:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Exit Sub
End Sub

une question : je ne vois rien pour tester le cas où 2 mails contiennent une pièce avec le même nom. Tu écrases ?