Lotus Notes Lotus Script

Sub OutPutLink

Dim rtf As NotesRichTextItem 
Dim session As New NotesSession 
Dim db As NotesDatabase 
Dim doc As NotesDocument   
Set db = session.CurrentDatabase 
Set doccol=db.AllDocuments '此方法仅能用于代理方能正常运行。
Set doc = doccol.GetFirstDocument() 
flg=False
If doccol.count>0 Then
    Set doc=doccol.Getfirstdocument()
    For i=1 To doccol.count
    On Error Resume Next
        Set rti=doc.GetFirstItem("Body")
    Set rtf=doc.GetFirstItem("Body")
        Set rtnav=rti.CreateNavigator
    Set rtlink = rtnav.getfirstelement(RTELEM_TYPE_DOCLINK)
        flg=True
    While (flg)
        If Not rtlink Is Nothing Then
	    Call rtf.BeginInsert(rtnav)
	    Call rtf.AppendText(rtlink.Docunid)
            Call rtf.EndInsert
	    Set rtlink = rtnav.getnextelement
	Else
	    flg=False
	End If
    Wend

        Call doc.Save(True,True)
    Set doc=doccol.getnextdocument(doc)
    Next
End If
Print "提取完毕！"

End Sub

Sub OutPutFile

Dim session As New NotesSession 
Dim db As NotesDatabase 
Dim doc As NotesDocument   
Dim rtitem As Variant 
Dim NotesItem As NotesItem 
Dim link As NotesRichTextDoclink
Dim flg As Boolean
Dim folderName As String
Dim id As String
Dim fileCount As Integer
fileCount=0
Dim subFolder As String
Set db = session.CurrentDatabase 
Set doccol=db.AllDocuments '此方法仅能用于代理方能正常运行。
Set doc = doccol.GetFirstDocument() 
flg=False

If doccol.count>0 Then

	Set doc=doccol.Getfirstdocument()

	For i=1 To doccol.count

		Set rtitem = doc.GetFirstItem( "Body" )

                    Set rtf = doc.GetFirstItem( "Body" )

		id=doc.UniversalID
		
		folderName  = "C:	emp" & "" & id
		
		On Error Resume Next
		
		fileCount=0
		
		If Dir$(folderName,16)="" Then
			Mkdir folderName
		End If
		
		Forall o In rtitem.EmbeddedObjects                     
			If ( o.Type = EMBED_ATTACHMENT ) Then
				subFolder = folderName & "" & fileCount
				If Dir$(subFolder,16)="" Then
					Mkdir subFolder
				End If

				Set obj=o

				If Not  obj Is Nothing Then
					Call rtf.BeginInsert(obj)
					Call rtf.AppendText("$$" & obj.Name & "$$")
					Call rtf.EndInsert
				End If

				Call o.ExtractFile(subFolder  & "" & o.Name) 
				fileCount=fileCount+1
			End If         
		End Forall 
		
		Dim attachName As Variant
		
		Dim attachObj As NotesEmbeddedObject
		
		attachName=Evaluate(|@AttachmentNames|,doc)
		
		Forall item In attachName               
			Set attachObj= doc.GetAttachment(item)
			If Not attachObj Is Nothing Then
				subFolder = folderName & "" & fileCount
				If Dir$(subFolder,16)="" Then
					Mkdir subFolder
				End If
				Call attachObj.ExtractFile(subFolder  & "" & item)
				fileCount=fileCount+1
			End If
		End Forall 
		
		Set doc=doccol.getnextdocument(doc)
	Next
End If
Print "提取完毕！"

End Sub