Probleme beim Kopieren von Attachments (RichText)

[Weixel]

Hallo @Notes-Gemeinde,

Vorab : Ich habe alle möglichen "Richtext Attachments Threads" hier im Forum durchgegangen und leider keine Hilfe für mein Problem gefunden.

Ich möchte ein RichtextItem mit einem Attachment von einem Dokument in ein RichTextItem eines anderes Dokuments kopieren.

Folgendes Szenario:
Datenbank "A" / Dokument "A" beinhaltet ein RichtextItem mit einem Anhang.
Diesen will ich über eine Aktion in Datenbank "B" / Dokument "B" in selbiges Dokument kopieren.

Code in Button:

Code

Sub Click(Source As Button)
	
	Dim workspace As New NotesUIWorkspace
	Dim session As New NotesSession
	Dim uidoc As NotesUIDocument
	Dim docB As NotesDocument
	Dim docStaff As NotesDocument
	Dim docA As NotesDocument
	Dim object As NotesEmbeddedObject
	Dim rtitem As NotesRichTextItem
	Dim dbB As NotesDatabase
	Dim dbA As New NotesDatabase ("","")
	Dim viewID As NotesView
	Dim collection As NotesDocumentCollection
	Dim docID As NotesDocument
	Dim colID As NotesDocumentCollection
	Dim strFilename As String
	Dim strID As String
	
	Const strDBPath = "xxx\xxx.nsf"
	
	On Error Goto ErrorHandler
	
	Set dbB = session.CurrentDatabase
	Set uidoc = workspace.CurrentDocument
	Set docB = uidoc.Document
	
	Call dbA.OpenWithFailover(dbB.Server,strDBPath)
	
	If dbA.IsOpen Then
		
		Set collection = workspace.PickListCollection( _
		PICKLIST_CUSTOM, _
		False, _
		dbB.Server, _
		strDBPath, _
		"Viewname", _
		"Anhangdokumente", _
		"Bitte wählen Sie ein Dokument aus.")
		If collection.Count = 0 Then
			Print "User canceled" 
			Exit Sub
		Else
			
			Set docStaff = collection.GetFirstDocument
			If Not docStaff Is Nothing Then
				
				Set viewID = dbA.GetView("(IDs)")
				
				strID = docStaff.GetItemValue("ID")(0)
				
				'Get Profile Document 
				Set colID = viewID.GetAllDocumentsByKey(Strleftback(strID,":"))
				
				For i = 1 To colID.Count
					Set docID = colID.GetNthDocument(i)
					
					If docID.GetItemValue("Form")(0) = "Profile" Then
						Set docA = docID						
					End If
				Next
				
				If Not docA Is Nothing Then
					
					Call docB.RemoveItem("ProfileAtt")			
					Call CopyItemBE(docB, docA, "Body", "ProfileAtt")	
					
				End If
			End If
		End If
	End If
	
	Call uidoc.Refresh(True,True)
	Call docB.Save(True, True)
	
	Dim unid As String
	Dim reopendoc As NotesDocument
	unid = docB.UniversalID 
	
	Call uidoc.FieldSetText("SaveOptions", "0")
	Call uidoc.Close 
	
	Delete docB
	Delete uidoc
	
	Set reopendoc = dbB.GetDocumentByUNID(unid) 
	Set uidoc = workspace.EditDocument(True , reopendoc) 
	
Ende:
	Exit Sub
	
ErrorHandler:
	Messagebox "Attachments kopieren - Fehler: " & Str$(Err) & " -> '" & Error$ & " in Zeile " & Str$(Erl) , 16, "Fehler"
	Resume Ende	
End Sub

Code

Function CopyItemBE(doc As NotesDocument, QDoc As NotesDocument, strname As String, strnewname As String)
	On Error Goto errHandler
	
	Dim item As NotesItem
	Dim session As New NotesSession
	Dim curdb As NotesDatabase
	Dim pathStaffDB As String
	
	strname = strReplace(strname, " ", "")	' replace spaces
	Set curdb = session.CurrentDatabase
	pathStaffDB = "xxxx\xxxx.nsf"
	
	If strnewname = "" Then				' if both names are the same
		strnewname = strname
	End If
	Set item = QDoc.GetFirstItem(strname)
	If Not item Is Nothing Then
		Call doc.CopyItem(item,strnewname)
	End If
	
	
GoOut:
	Exit Function
	
errHandler:
	Msgbox "Fehler #" & Err & " — " & Error$ & " (Zeile: " & Erl & ")" + Chr(13) + Chr(13) + MsgError, 48, MsgErrorTitle
	Resume GoOut
End Function

Er kopiert nun das Attachment.
Allerdings liegt es nicht in dem RichTextItem "ProfileAtt", sondern wird einfach immer unten im Dokument angehängt.

Vielen Dank schonmal für die Hilfe

MfG
Patrick

[koehlerbv]

Es spricht einiges dafür, dass nicht alle Items namens "ProfileAtt"vor dem CopyItem beseitigt wurden. Hier würde ich als erstes ansetzen.

Bernhard

[Weixel]

Also nochmal mein Ablauf:

Ich erstelle ein neues Dokument und starte dort über einen Button das Einfügen des Attachments.

Habe es nun auch über RTItem Handling (Append) probiert :

Code

If Not docProfile Is Nothing Then
					
  'Call doc.RemoveItem("ProfileAtt")					
  Call CopyItemBE(doc, docProfile, "Body", "ProfileAtt")	
					
End If

Code

Function CopyItemBE(doc As NotesDocument, QDoc As NotesDocument, strname As String, strnewname As String)
.
.
.
'Hier holt er sich das RichTextItem mit dem Attachment (korrekt gesetzt)
Set rtiBody = QDoc.GetFirstItem(strname)
	If Not rtiBody Is Nothing Then
		
                'Das Ziel RTItem , welches auch korrekt gesetzt wird
		Set rtiAttachment = doc.GetFirstItem(strnewname)
		
                'Überspringt er logischerweise
		If rtiAttachment Is Nothing Then
			Set rtiAttachment = New NotesRichTextItem (doc,strnewname)
		End If
		
		'Und genau hier ist der Fehler, es verändert sich nichts am rtiAttachment
		Call rtiAttachment.AppendRTItem(rtiBody)

		'Call doc.CreateRichTextItem(strnewname)
		'Call doc.CopyItem(item,strnewname)
	End If

GoOut:
	Exit Function

Anbei noch ein Screenshot vom Debugger, wenn ich über die besagte Zeite gehe (nachdem)

Bin echt ratlos