把notes里的以OLE形式存放的对象，导出成一个文件。

Sub Click(Source As Button)

On Error Goto isoErr

Dim w As New NotesUIWorkspace

Dim s As New NotesSession

Dim isoLog As New NotesLog("WriteIso")

Dim dbCur As NotesDatabase

Dim dclCur As NotesDocumentCollection

Dim docCur As NotesDocument

Dim ole As NotesEmbeddedObject

Dim att As Variant

Dim dbNew As NotesDatabase

Call isoLog.OpenFileLog("d:\isoLog.txt")

' isoLog.OverwriteFile=True

isoLog.LogAction("===========================当前时间是："+Now()+"======================================")

Set dbCur=s.CurrentDatabase

Set dbNew=s.GetDatabase("CN=zhbpms/O=gdtel","zhteloa\IsoFileManager.nsf",False)

%REM

Dim docIso As NotesDocument

Dim docF As NotesDocument

Set docIso=dbNew.CreateDocument

Set docF=dbNew.GetDocumentByUNID("9D7EE71D70644E7048256F3800345178")

docIso.form="F_DeptFile"

docIso.ParentDocUNID="9D7EE71D70644E7048256F3800345178"

docIso.Str_Type="File"

docIso.FolderName="导出操作"

docIso.Str_OrgType="Org"

docIso.DocID=docIso.UniversalID

docIso.delSymbol="0"

docIso.dbpath="zhteloa/IsoFileManager.nsf"

If docIso.Save(True,False) Then

Call docIso.MakeResponse(docF)

Call docIso.Save(True,False)

Else

isoLog.LogAction("a")

End If

%ENDREM

Set dclCur=dbCur.UnprocessedDocuments

If dclCur.Count>0 Then

Set docCur=dclCur.GetFirstDocument

While Not docCur Is Nothing

'拆离旧ISO的数据

If docCur.HasEmbedded Then

Dim App

Dim Document

Dim RTItem As NotesRichTextItem

Dim Embedded As NotesEmbeddedObject

Set RTItem = docCur.GetFirstItem("Body")

Set Embedded = RTItem.EmbeddedObjects(0)

Call Embedded.Activate(True)

Set App = Embedded.Object

'处理excel

If docCur.~$OLEObjProgID(0)="Excel.Sheet" Then

Call app.saveAs("d:\"+docCur.UniversalID+".xls")

' Set wks=app.Application.Worksheets(1)

' Call wks.saveAs("d:\"+docCur.UniversalID+".xls")

' App.Application.ActiveDocument.SaveAs("d:\\"+docCur.UniversalID+".xls")

End If

'处理ppt

If docCur.~$OLEObjProgID(0)="PowerPoint.Show" Then

Call app.saveAs("d:\"+docCur.UniversalID+".ppt")

End If

'处理word

If docCur.~$OLEObjProgID(0)="Word.Document" Then

Call app.saveAs("d:\"+docCur.UniversalID+".doc")

' Set Document = App.Application.Documents(1)

' Call Document.saveAs("d:\\"+docCur.UniversalID+".doc")

End If

'把拆离出来的数据放到新的OA库中

Dim docIso As NotesDocument

Dim rtf As NotesRichTextItem

Dim docF As NotesDocument

Dim vwOrg As NotesView

Dim dclSec As NotesDocumentCollection

Set docIso=dbNew.CreateDocument

Set vwOrg=dbnew.GetView("vwRootF")

'找一级文件夹

If doccur.LargeKind(0)<>"" Then

' Dim key As String

' If doccur.LargeKind(0)="质量记录表格清单" Or doccur.LargeKind(0)="质量记录表格清单" Then

' key="质量记录表样及清单"

' Else

' key=doccur.LargeKind(0)

' End If

Set docF=vwOrg.GetDocumentByKey(doccur.LargeKind(0))

If docF Is Nothing Then

isoLog.LogAction("新OA中没有“"+doccur.LargeKind(0)+"”这个一级分类！")

Goto nextProDoc

End If

'查找二级文件夹

If doccur.SecondKind(0)<>"" Then

Set dclSec=docF.Responses

Dim docTmp As NotesDocument

Dim hasSec As Boolean

hasSec=False

If dclsec.Count>0 Then

For i=1 To dclsec.Count

Set docTmp=dclsec.GetNthDocument(i)

If docTmp.FolderName(0)=doccur.SecondKind(0) Then

Set docF=docTmp

hasSec=True

End If

If (Not hasSec) Or dclSec.Count=0 Then

isoLog.LogAction("新OA中没有“"+doccur.SecondKind(0)+"”这个二级分类！")

Goto nextProDoc

End If

docIso.form="F_DeptFile"

docIso.ParentDocUNID=docF.UniversalID

docIso.Str_Type="File"

docIso.FolderName=docCur.subject(0)

docIso.Str_OrgType="Org"

docIso.DocID=docIso.UniversalID

docIso.delSymbol="0"

docIso.dbpath="zhteloa/IsoFileManager.nsf"

docIso.Hidden="0"

docIso.isArchivesAttach=""

'设置正文信息

docIso.HasWordDoc="1"

IsUseUpTemplate="0"

OFileName=docCur.UniversalID+".doc"

OFileDate=""

Dim srcFileName As String

Set rtf=docIso.CreateRichTextItem("LastVersionDoc")

If docIso.Save(True,False) Then

If docCur.~$OLEObjProgID(0)="Excel.Sheet" Then

srcFileName=docCur.UniversalID+".xls"

' Set wks=app.Application.Worksheets(1)

' Call wks.saveAs("d:\"+docCur.UniversalID+".xls")

' App.Application.ActiveDocument.SaveAs("d:\\"+docCur.UniversalID+".xls")

End If

'处理ppt

If docCur.~$OLEObjProgID(0)="PowerPoint.Show" Then

srcFileName=docCur.UniversalID+".ppt"

End If

'处理word

If docCur.~$OLEObjProgID(0)="Word.Document" Then

srcFileName=docCur.UniversalID+".doc"

' Set Document = App.Application.Documents(1)

' Call Document.saveAs("d:\\"+docCur.UniversalID+".doc")

End If

Call rtf.EmbedObject(EMBED_ATTACHMENT,"","d:\\"+srcFileName,srcFileName)

Call docIso.MakeResponse(docF)

Call docIso.Save(True,False)

Else

isoLog.LogAction("a")

End If

nextProDoc:

Set docCur=dclCur.GetNextDocument(docCur)

Wend

End If

isoLog.LogAction("===========================当前时间是："+Now()+"======================================")

Call isoLog.Close

Exit Sub

isoERR:

Print "第"+Cstr(Erl())+" 行，出现 "+Error()+" 错误"

isoLog.LogAction(Cstr(Erl())+" "+Error())

Call isoLog.Close

End Sub