Ich habe hier auf die Schnelle mal was zusammengestrickt, aus Zeitgründen aber leider nicht getestet. Die Fehlerbehandlung ist auch sehr rudimentär.
Sub Click(Source As Button)
Dim workspace As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim object As NotesEmbeddedObject
Dim rtitem As NotesRichTextItem
Dim strFilename As String
Const strPath = "C:\Temp\"
On Error Goto ErrorHandler
Set uidoc = workspace.CurrentDocument
Set doc = uidoc.Document
'Lösen des Anhangs
Set rtitem = doc.GetFirstItem( "RTF1" )
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
strFilename = strPath & o.Source
Call o.ExtractFile( strFilename )
End If
End Forall
End If
'Anhängen der Datei
Set rtitem = doc.GetFirstItem( "RTF2" )
Set object = rtitem.EmbedObject( EMBED_ATTACHMENT, "", strFilename)
'Löschen der Datei
Kill strFilename
Ende:
Exit Sub
ErrorHandler:
Messagebox "Attachments kopieren - Fehler: " & Str$(Err) & " -> '" & Error$ & " in Zeile " & Str$(Erl) , 16, "Fehler"
Resume Ende
End Sub
Axel
Stimmt.
Dafür gibt's doch was von....
...unserem Kollegen Anton (ata)
REM Das aktuelle Dokument schließen und wieder öffnen......
Function ReOpen(docThis As NotesDocument) As Integer
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim dbThis As NotesDatabase
Dim unid As String
ReOpen = 0
Set dbThis = docThis.ParentDatabase
Call docThis.Save(True , True)
unid = docThis.UniversalID
docThis.SaveOptions = "0" ' # ... Speicherabfrage vermeiden
Set uidoc = ws.CurrentDocument
Call uidoc.Close
Set docThis = dbThis.GetDocumentByUNID(unid)
Set uidoc = ws.EditDocument(True , docThis)
Set docThis = uidoc.Document
If docThis.HasItem("SaveOptions") Then
' # ... das Feld SaveOptions wieder entfernen...
docThis.RemoveItem("SaveOptions")
Call docThis.Save( True , True )
End If
ReOpen = 1
Print "Das Dokument wurde erneut geöffnet"
End Function
Den Quelltext der Funktion fügst du mit Copy & Paste in den (Options)-Abschnitts des Hotspots oder der Maske ein.
Den Funktionsaufruf selbst machst du dann nach dem die Datei wieder angehängt wurde.
...
'Anhängen der Datei
Set rtitem = doc.GetFirstItem( "RTF2" )
Set object = rtitem.EmbedObject( EMBED_ATTACHMENT, "", strFilename)
'Löschen der Datei
Kill strFilename
Call Reopen(doc)
....
Axel
Yoo.
...
'Lösen des Anhangs
Set rtitem = doc.GetFirstItem( "RTF1" )
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
strFilename = strPath & o.Source
Call o.ExtractFile( strFilename )
Call o.Remove
End If
End Forall
End If
...
Axel