把notes裏的以OLE形式存放的對象，導出成一個文件。

把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