lotus notes 数据库中附件的批量导出代码,Domino代码库,德仔网

代码语言
代码分类
【Domino】 lotus notes 数据库中附件的批量导出
作者:entry / 发布于2014/7/25/ 1113

	Public Class getAllNotesEmObject
	'-------------------------------------------------------------------
	'******功能： 可以在视图中直接提取文档中RTF域附件的类 *******
	'-------------------------------------------------------------------
	 Private filenum As Integer
	 Private folder As String
	 Private rtfField As String
	 Private fileType As String
	 Public doc As Notesdocument
	'Private writeStr As String
	'=============设置文件夹路径==============
	 Sub setFolder(f As String)
	 folder=f
	 End Sub
	'=============设置RTF域名称===============
	 Sub setRtfFieldName(rf As String)
	 rtfField=rf
	 End Sub
	'=============设置doc===============
	 Sub setDoc(document As Variant)
	 Set doc=document
	 End Sub
	 Sub getObject(wStr1 As String)
	'------------------------------
	'用法：getObject(域名A)
	'备注：域名A作为子文件夹存放不同的文件,注意各个文档的A要不同才不致于覆盖
	'------------------------------
	 Dim s As New Notessession
	 Dim db As Notesdatabase
	
	 Dim eobject As Notesembeddedobject
	 Dim rtfitem As Variant
	 Dim item1,item2 As notesitem
	 Dim tempName As String
	 Dim exportName As String
	 Dim exportLastName As String
	 Dim i,j,k ,m As Integer
	 filenum=Freefile()
	 k=0 '用来记录错误个数
	 m=1 '用来记录同名的文件数,默认为1
	 Set db=s.GetDatabase("d23dbl35","dbom\caiyi\chinao1.nsf")
	
	 If folder="" Then Exit Sub
	 On Error Resume Next
	'直接建立目录
	 Mkdir folder
	
	 Set item1=doc.getfirstitem(wStr1) '子文件夹
	 writeStr=item1.values(0)
	 Print "正在提取["+writeStr+"]的附件"
	 Set rtfitem=doc.getfirstitem(rtfField) 'rtfField:RTF域的域名
	 j=0
	 Mkdir folder+"\"+writeStr
	 Forall ob In rtfitem.Embeddedobjects
	'=========2005/07/07=============
	' 修改为以附件的名称直接拆离即可
	 ob.Extractfile(folder+"\"+writeStr+"\"+ob.name)
	 exportName=folder+"\"+writeStr+"\"+ob.name
	
	 If exportName=exportLastName Then
	 m=m+1
	 ob.Extractfile(Left(exportName,Len(exportName)-4)+"("+Cstr(m)+")"+Right(ob.name,4))
	 Else
	 m=1
	 ob.Extractfile(exportName)
	 End If
	
	 exportLastName=exportName
	
	 End Forall
	'==========写入错误日志===============
	 If Err=92 Then
	 Open folder+"\faillog"+Cstr(Today)+".txt" For Output As fileNum
	 Write #filenum%,writeStr+"没有附件"+newline
	 k=1
	 End If
	'===============================
	 Err=0
	
	 Close filenum
	 If k=1 Then
	 k="部分有错误，请查看文件夹中faillog"+Cstr(Today)+".TXT的记录"
	 Else
	 k=""
	 End If
	 Print "提取完毕！请到"+folder+"文件夹中查找。"+k
	
	 End Sub
	End Class

	

	

	

	

	

	

	Sub Initialize
	 Dim s As New Notessession
	 Dim db As Notesdatabase
	 Dim doccol As Notesdocumentcollection
	 Dim doc As Notesdocument
	 Dim folder As String
	 Set db=s.GetDatabase("d23dbl35","dbom\caiyi\chinao1.nsf")
	 folder=Inputbox$("请填写保存路径，如C:\TEMP或C:","系统提示","c:\temp")
	 If Trim(folder)="" Then
	 Msgbox "保存路径有误，请重新运行程序",16+64,"系统提示"
	 Else
	 Set doccol=db.AllDocuments '此方法仅能用于代理方能正常运行。
	 If doccol.count>0 Then
	 Set doc=doccol.Getfirstdocument()
	 For i=1 To doccol.count
	 Dim nToE As New getAllNotesEmObject '实例化自定义提取附件类
	 nToE.setRtfFieldName("Body") '定义附件RTF域
	 nToE.setfolder(folder) '定义保存路径
	 Set nToE.doc=doc '定义要提取附件的DOC
	 nToE.getObject("OCRM") '使用自定义类中提取附件方法
	 Set nToE=Nothing '释放内存
	
	 Set doc=doccol.getnextdocument(doc)
	
	 Next
	 End If
	 End If
	End Sub
试试其它关键字
　批量导出　
同语言下
可能有用的
entry贡献的其它代码(10)