C/S下的Excel的导入

Sub ImportContact(docType As String)

    On Error Goto handler
    
    Dim s As New NotesSession
    Dim w As New NotesUIWorkspace
    Dim uidoc As NotesUIDocument
    Dim doc As NotesDocument
    
    Set db = s.CurrentDatabase    
    Set uidoc = w.Currentdocument
    Set doc = uidoc.Document
    
    Call InitVariant(docType)    
    
    Dim filenames    
    filenames = w.OpenFileDialog(False,"导入","Excel 工作簿(*.xlsx)|*.xlsx", "D:\", FileName)
    If Isempty(filenames)Then
        Exit Sub
    End If
    FileName  = filenames(0)
    
    Dim Excel As Variant,workbooks As Variant,worksheet As Variant 
    
    Dim l As Long 
    l = Asc(FileName)    
    If l =0 Then Exit Sub        
    
    Set Excel = CreateObject("Excel.Application")
     ‘Excel.Visible= True
    Set workbooks=Excel.Workbooks.Open(FileName)
    Set workSheet = Workbooks.WorkSheets(1) 
    ‘检查模板
    If TemplateCheck(docType,worksheet) = False Then 
        Msgbox "请选用系统提供的导入模板,再导入!" ,64, "Lotus Notes"
        Call workbooks.Close
        Call Excel.Quit            
        Exit Sub
    End If
    
    If docType = "Tps" Then
        LineNo = ImportRowsAsNewDoc(worksheet,uidoc,itemName,2,1,1)    
    End If
    
    doc.ImportInfo = "已导入"+CStr(LineNo)+"条数据"
    Call uidoc.Save
    
    Call workbooks.Close    
    Call Excel.Quit        
    
    Messagebox "数据导入完毕，总计导入" & Cstr(lineNo) & "条数据。",64,"Lotus Notes"
    
    ‘刷新视图
    Call w.ViewRefresh
    
    Exit Sub
handler:
    Messagebox Error ,64,"Lotus Notes"
    If Err= 30001 Then
        If Isempty(Excel) Then
        Else
            Excel.Visible= True 
        End If 
    Else
        If Isempty(Excel) Then
        Else
            ‘Call workbooks.Close
            Call Excel.Quit
        End If 
    End If          
    Exit Sub 
End Sub

Sub InitVariant (docType As String)
%REM
2     Integer
3     Long
4     Single
5     Double
6     Currency
7     Date/Time
8     String
9    Name
%END REM
    
    If docType = "Tps" Then 
        Redim itemName(3)    
        itemName(1) = ""
        itemName(2) = ""
        itemName(3) = ""
        
        
        Redim itemType(3)            
        itemType(1) = 8
        itemType(2) = 8
        itemType(3) = 8
        
        key = "01"    ‘模板关键字
        FileName = "XXXX.xls"    
        docForm = "item"
    End If    
    
    
End Sub

Function TemplateCheck(docType As String,worksheet As Variant) As Integer
    ‘检查导入时是否使用了指定的模板
    TemplateCheck = False
    
    If docType = "Tps"  Then 
        Dim columnName(3) As String
        columnName(1) ="XXX"
        columnName(2) ="XXX"
        columnName(3) ="XXX"
        
        For i = 1 To 3 
            Print worksheet.Cells(1,i).value
            If Trim(worksheet.Cells(1,i).value) <> columnName(i) Then 
                Exit Function
            End If
        Next
    End If    
    
    
    TemplateCheck = True
    
    
End Function

Function ImportRowsAsNewDoc(worksheet As Variant,uidoc As NotesUIDocument, itemName As Variant,  _ 
rows As Integer,columns As Integer,key As Integer)  As Integer
‘worksheet As Variant,        工作表
‘itemName As Variant,         字段名列表
‘uidoc As NotesUIDocument,    当前文档
‘rows As Integer,            开始行
‘columns As Integer            开始列    
‘key As Integer            字段列表中，以某个域为空作为结束判断，key为空的域的高序列号
    
    Print "正在导入数据..."
    
    ImportRowsAsNewDoc = 0    
    Dim lineNo,ColumnsCount,RowsCount As Integer    
    
    Dim SpaceFiled As String    
    Dim newdoc As NotesDocument
    
    Dim workno As String
    Dim fullName As String
    Dim cellvalue As String
    Dim replacevalue As String
    Dim newrzCode As String
    Dim keys() As String
    Dim item As NotesItem
    
    Dim vw As NotesView
    Dim db As NotesDatabase
    Dim cfgdoc As NotesDocument
    Dim doc As NotesDocument
    Dim dbTarget As NotesDatabase
    Dim dcc As NotesDocumentCollection
    Dim link As NotesRichTextItem
    Dim ss As New NotesSession
    Set db = ss.Currentdatabase
    Set doc = uidoc.Document
    
    ‘找到目标库路径配置
    Set vw = db.Getview("")
    Set cfgdoc = vw.Getdocumentbykey("",True)
    If cfgdoc Is Nothing Then
        MsgBox "没有找到配置请联系管理员进行配置！"
        Exit Function
    End If
    ‘激活目标库
    Set dbTarget = New NotesDatabase(Server,DbPath)
    If Not dbTarget.Isopen Then
        If dbTarget.open(DbServer,DbPath) Then
        Else
            MsgBox "无法打开或不存在数据库",64,"Lotus Notes"
            Exit Function
        End If
    End If
    
    Set vw = dbTarget.Getview("")
    If vw Is Nothing Then
        MsgBox "找不到匹配视图！"
        Exit Function
    End If
    ‘根据装备名称找到相关项目编码，并做清空初始化
    Set dcc = vw.Getalldocumentsbykey(doc.xxx(0),True)
    If dcc.Count > 0 Then
        Call dcc.Removeall(True)
    End If
    
    lineNo =1    
    ColumnsCount = UBound(itemName)
    RowsCount = rows        
    
    SpaceFiled = Trim(worksheet.Cells(Rows,columns+key-1).value) 
    lineNo = 1
    RowsCount = rows
    
    ‘遍历Excel导入
    While Len(Trim(SpaceFiled))>0    
        
        Set newdoc = dbTarget.CreateDocument
        newdoc.form = docForm
        Call newdoc.Replaceitemvalue("Author","[administrator]")
        Set item = newdoc.Getfirstitem("Author")
        item.Isauthors = True
        
        Call newdoc.Replaceitemvalue("Reader","*")
        Set item = newdoc.Getfirstitem("Reader")
        item.Isreaders = True
        
        Set link=newdoc.CreateRichTextItem("link")
        Call link.AppendText( "" )
        Call link.Appenddoclink(doc,")
        
        Call newdoc.Replaceitemvalue("xxx",doc.xxx(0))                        
               
        Call newdoc.Replaceitemvalue("parentdocid",doc.Universalid)                
        Call newdoc.Replaceitemvalue("CreateTime",Now)                            ‘创建日期
        
        Call newdoc.Replaceitemvalue("code1",Trim(worksheet.Cells(RowsCount,1).value))        
        Call newdoc.Replaceitemvalue("code2",Trim(worksheet.Cells(RowsCount,2).value))        
        Call newdoc.Replaceitemvalue("code3",Trim(worksheet.Cells(RowsCount,3).value))        

        
        Print CStr(lineNo) 
            
        ImportRowsAsNewDoc = lineNo
        lineNo = lineNo+1            
        RowsCount=RowsCount+1    
            
        SpaceFiled = Trim(worksheet.Cells(RowsCount,columns+key-1).value)    
    
        
        Call newdoc.Save(True,False)
    Wend
    
End Function