把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
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
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
Next
End If
If (Not hasSec) Or dclSec.Count=0 Then
isoLog.LogAction("新OA中没有“"+doccur.SecondKind(0)+"”这个二级分类！")
Goto nextProDoc
End If
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
本文地址：http://com.8s8s.com/it/it26126.htm