综合

img gzxiaohao

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

发表于2004/10/28 20:58:00  736人阅读

把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
阅读全文
0 0

相关文章推荐

img
取 消
img