CS端导入Excel

Sub Click(Source As Button)
 On Error Goto e
 Dim ws As New NotesUIWorkspace           'workspace
 Dim ss As New NotesSession                    'session
 Dim db As NotesDatabase                        'database
 Dim files As Variant,wjj As String,filename As String                                  'file name
 Dim schar As String                                  'cell content
 Dim tdoc As NotesDocument                      'notes document
 Dim excelapplication
 Dim i,sheet
 Set db = ss.currentdatabase
 files = ws.openfiledialog(True,"请选择要导入的Word文件相应的Excel文件","Excel file/*.xls","e:/")
 sheeet = 1
 If Not(Isempty(files)) Then 
  answer% = Messagebox("你确定要导入所选中的文件?",4,"确定?")
  If answer%<>6 Then
   Exit Sub
  End If
  
  Forall tmpfile In files
   If Right(tmpfile,4)=".xls"Then
    
    filename=Strrightback(tmpfile,"/")
    wjj = Strleft(tmpfile,"/"+filename)
    
    Set excelapplication = createobject("excel.application")
    Set excelworkbook = excelapplication.workbooks.open(tmpfile)
    
    If excelworkbook Is Nothing Then            '如果未找到文件，则退出
     excelapplication.quit
     Exit Sub
    End If
    Set tmpSheet = excelworkbook.worksheets(1)
    i = 2   '从第二行开始读取
    
    Set tdoc = New NotesDocument(db)
    tdoc.form="FrmTL9000"
    tdoc.CopyWriterDept=tmpSheet.Cells(2,1).Value
    tdoc.FlCopyWriter=tmpSheet.Cells(2,2).Value
    
   'tmptime$=tmpSheet.Cells(2,3).Value
    tdoc.FlYear=Year(tmpSheet.Cells(2,3).Value)
    tdoc.FlMonth=Month(tmpSheet.Cells(2,3).Value)
    tdoc.FlDay=Day(tmpSheet.Cells(2,3).Value)
    tdoc.FlSubject=tmpSheet.Cells(2,4).Value
    tdoc.FileNO=tmpSheet.Cells(2,5).Value
    tmpserial$=Ucase(tmpSheet.Cells(2,6).Value)
    tdoc.serial=Strleft(tmpserial$,"V")
    tdoc.No=Strright(tmpserial$,"V")
    tdoc.versionNo=tmpserial$
   'tdoc.startDate=tmpSheet.Cells(2,7).Value
    If Instr(tmpSheet.Cells(2,7).Value,"年")>0 Then
     tdoc.startDate=tmpSheet.Cells(2,7).Value
    Else
     tdoc.startDate=Year(tmpSheet.Cells(2,7).Value) & "年" & Month(tmpSheet.Cells(2,7).Value) & "月" & Day(tmpSheet.Cells(2,7).Value) &"日"
    End If
    
   'tdoc.FaBuRange=tmpSheet.Cells(2,8).Value
    Set item=New NotesItem(tdoc,"FaBuRange","")
    
    
    Forall tmpFaBu In SplitStringExt(tmpSheet.Cells(2,8).Value,";")
     item.AppendToTextList(tmpFaBu)
    End Forall  
    
    tdoc.IsCheck="1"
    tdoc.IsSGS="0"
    tdoc.DocUNID=tdoc.UniversalID
    tdoc.wordunid=tdoc.UniversalID
    tdoc.FileType="Tl9000"
    
    Set item=New NotesItem(tdoc,"FaBuReaders","")
    If Instr(tmpSheet.Cells(2,8).Value,"公司全体员工")>0 Then
     item.AppendToTextList("*")
    Else
     item.AppendToTextList("中山分公司公司领导")
     item.AppendToTextList("中山分公司综合部")
     item.AppendToTextList("中山分公司" & tdoc.CopyWriterDept(0))
     Forall tmpdept In tdoc.FaBuRange
      item.AppendToTextList("中山分公司" & tmpdept)     
     End Forall
     item.Values=Fulltrim(Arrayunique(item.Values))
     item.IsReaders=True
    End If
    Set item=New NotesItem(tdoc,"DocAdmin","")
    item.AppendToTextList("[文档管理员]")
    item.IsAuthors=True
    
    docname$=Strleft(filename,".xls") & ".doc"
    Set rtitem=New notesrichtextitem(tDoc,"FileAttach")
    On Error Resume Next
    
    Call rtitem.EmbedObject(EMBED_ATTACHMENT,"",wjj & "/" & docname$,"FileAttachment")
    
    
    tdoc.FilesName=docname$
    Call tdoc.Save(True,False)
    
    excelworkbook.close(False)
    excelapplication.quit
    Set excelapplication = Nothing
   End If
  End Forall
  
 End If
 Exit Sub
e:
 Msgbox Cstr(Erl)+Error$
End Sub