ผมพอมีเคยทำเป็น Function ไว้บ้างครับ ตัวนี้รับ parameter มาเป็น document ที่เราต้องการ Archive Attachment ไปที่ database ปลายทาง ยังไงลองไล่ดูก่อนนะครับ
Function ProcessAttachment(db As NotesDatabase, doc As NotesDocument, force As Integer) As Integer
' db is a Current Database
' doc is selected document
' force is force update attachment in archive without comfirm
' 0 = No update
' 1 = Replace Existing Attachment
' 2 = Prompt Existing Attachment
On Error Goto Errhandle
ProcessAttachment = False
Dim newdoc As NotesDocument
Dim attachname As Variant
Dim attachsize As Variant
Dim IsAttachment As Boolean
Dim objectarray() As String
Dim count As Integer
Dim unid As String
IsAttachment = False
doc.ArchiveFlag = "Fail"
attachname = Evaluate(|@AttachmentNames|, doc)
attachsize = Evaluate(|@AttachmentLengths|, doc)
Set rtitem1 = doc.GetFirstItem( "Body" )
If db.Server = "" Then
ArchiveServer = ""
Else
ArchiveServer = profile.ArchiveServer(0)
End If
Set targetdb = New NotesDatabase(ArchiveServer, profile.ArchiveDB(0))
If Not targetdb.IsOpen Then
ErrMsg = profile.ArchiveTitle(0) & "'s Archive database not found in that server or you are not authorize to open a database." & Chr(13) & "Please contact admin to correct this problem."
Print ErrMsg, 0+64, "Error"
Goto DBArchiveError
Exit Function
End If
Set targetview = targetdb.GetView("UNID")
Call targetview.Refresh
Set note = targetview.GetDocumentByKey(doc.UniversalID)
If Not (note Is Nothing) Then
note.Form = "Attachment"
note.SourceServer = db.Server
note.SourceDb= db.FilePath
note.SourceTitle = db.Title
note.RemoveItem("DocLink")
Set rtlink = New NotesRichtextItem(note, "DocLink")
Call rtlink.AppendDocLink(doc, "")
note.PROCESSOS = doc.PROCESSOS
note.INSTANCEOS = doc.INSTANCEOS
note.IssueDate = doc.COMPLETIONDATEOS
If note.HasItem("Body") Then
Set rtitem2 = note.GetFirstItem( "Body" )
Else
Set rtitem2 = New NotesRichTextItem(note, "Body" )
End If
count = -1
If ( rtitem2.Type = RICHTEXT ) Then
If Not Isempty(rtitem2.EmbeddedObjects) Then
If force = 2 Then
answer% = Messagebox("Archive file is already exist in archive. Do you want to update this attachment?", 4+32, "Continue?")
If Not answer% = 6 Then
pos = 0
Print "Agent being remove duplicated attachment from target database."
Exit Function
End If
Elseif force = 0 Then
Exit Function
End If
Forall o In rtitem2.EmbeddedObjects
If Not o Is Nothing Then
If o.Type = EMBED_ATTACHMENT Then
count = count + 1
Redim Preserve objectarray(count)
objectarray(count) = o.Name
End If
End If
End Forall
Forall m In objectarray
If Not Isempty(rtitem2.EmbeddedObjects) Then
Set object = rtitem2.GetEmbeddedObject( m )
If ( Not object Is Nothing ) Then
Call object.Remove
End If
End If
End Forall
End If
Call rtitem2.AppendRTItem( rtitem1 )
End If
Else
Set newdoc = New NotesDocument(targetdb)
newdoc.DocumentID = doc.UniversalID
newdoc.Form = "Attachment"
newdoc.SourceServer = db.Server
newdoc.SourceDb= db.FilePath
newdoc.SourceTitle = db.Title
Set rtlink = New NotesRichtextItem(newdoc, "DocLink")
Call rtlink.AppendDocLink(doc, "")
newdoc.PROCESSOS = doc.PROCESSOS
newdoc.INSTANCEOS = doc.INSTANCEOS
newdoc.IssueDate = doc.COMPLETIONDATEOS
If newdoc.HasItem("Body") Then
Set rtitem2 = newdoc.GetFirstItem( "Body" )
Else
Set rtitem2 = New NotesRichTextItem(newdoc, "Body" )
End If
Call rtitem2.AppendRTItem( rtitem1 )
End If
count = -1
If ( rtitem1.Type = RICHTEXT ) Then
If Not Isempty(rtitem1.EmbeddedObjects) Then
Forall o In rtitem1.EmbeddedObjects
If Not o Is Nothing Then
If o.Type = EMBED_ATTACHMENT Then
count = count + 1
Redim Preserve objectarray(count)
objectarray(count) = o.Name
End If
End If
End Forall
Print "Agent being remove attachment from source database."
Forall m In objectarray
If Not Isempty(rtitem1.EmbeddedObjects) Then
Set object = rtitem1.GetEmbeddedObject( m )
If ( Not object Is Nothing ) Then
Call object.Remove
pos = pos + 1
Print "Agent finish remove attachment from source database."
IsAttachment = True
End If
End If
End Forall
End If
End If
If IsAttachment = True Then
If Not (note Is Nothing) Then
Call note.Save(True, False)
unid = note.UniversalID
Else
Call newdoc.Save(True, False)
unid = newdoc.UniversalID
End If
If doc.HasItem("DDDocumentID") Then
doc.O_DDDocumenID = doc.DDDocumentID
doc.DDDocumentID = unid
End If
doc.ArchiveParentDocumentID = doc.DocUNID(0)
doc.ArchiveFileName = attachname
doc.ArchiveFileSize = attachsize
doc.ArchiveDocumentID = unid
doc.ArchiveDate = Now
doc.ArchiveFlag = "Yes"
Call doc.Save(True, False)
Print "Agent finish process attachment update successful."
ProcessAttachment = True
End If
Exit Function
DBArchiveError:
Print "Error in ProcessAttachment"
End Function |