C/S下的Excel的導入

1.入口函數

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

2.初始化函數

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

3.模板校驗

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

4.導入主體程序

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