Domino 9 und frühere Versionen > ND8: Entwicklung

Probleme beim Kopieren von Attachments (RichText)

(1/1)

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

--- Ende Code ---


--- 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

--- Ende Code ---


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
--- Ende Code ---


--- 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
--- Ende Code ---

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

Bin echt ratlos

Navigation

[0] Themen-Index