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 Subhandler:    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)%REM2     Integer3     Long4     Single5     Double6     Currency7     Date/Time8     String9    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