lotus notes 数据库中附件的批量导出

标签：blog   http   io   os   使用   ar   for   文件   数据   

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

再建一操作，写上：
@Command([ToolsRunMacro];"getEmObject")
然后在视图中使用此按键，即可从视图上直接下载附件。

出处：  http://zwm136200.blog.163.com/blog/static/428967962011110114926539/

lotus notes 数据库中附件的批量导出

标签：blog   http   io   os   使用   ar   for   文件   数据   

原文地址：http://www.cnblogs.com/Ellen/p/3979856.html