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/
