LOTUS/DOMINO学习笔记之导出到EXCEL的方法

传递要导出的视图名和工作表名

Function OutputExcel(ViewName As String,SheetName As String)
    Dim session As New NotesSession 
    Dim db As NotesDatabase 
    Dim view As Notesview
    Dim colls As NotesDocumentCollection
    Dim doc As Notesdocument
    Dim doc2 As Notesdocument
    Dim excelapplication As Variant 
    Dim excelworkbook As Variant 
    Dim excelsheet As Variant 
    Dim i As Integer 
    Dim uvcols As Integer 
    Dim selection As Variant 
    path=session.GetEnvironmentString ("D:",True)
    Set excelapplication=CreateObject("Excel.Application")
    excelapplication.statusbar="正在创建工作表，请稍等.."
    excelapplication.Visible=True
    excelapplication.Workbooks.Add
    excelapplication.referencestyle=2
    Set excelsheet=excelapplication.Workbooks(1).worksheets(1)
    excelsheet.name=SheetName '工作表的名字
    Dim rows As Integer 
    Dim cols As Integer 
    Dim maxcols As Integer 
    Dim fieldname As String 
    Dim fitem As NotesItem 
    rows=1
    cols=1
    Set db=session.CurrentDatabase 
    Set view=db.GetView (ViewName)
    Set colls=db.UnprocessedDocuments
    uvcols=Ubound(view.Columns)
    For x=0 To Ubound(view.Columns)
        excelapplication.statusbar="正在创建单元格，请稍等.."
        If view.Columns(x).IsHidden=False Then
            If view.Columns(x).title<>"" Then
                excelsheet.Cells(rows,cols).value=view.Columns(x).Title
                cols=cols+1 
            End If
        End If
    Next
    maxcols=cols-1
    Set doc=view.GetFirstDocument    
    Set doc2=colls.GetFirstDocument
    rows=2
    cols=1        
    Dim inside As Boolean
    inside=False
    
    While Not(doc Is Nothing)    
        For x=0 To Ubound(view.Columns)
            excelapplication.statusbar="正在从Notes中引入数据，请稍等.."
            fieldname=view.Columns(x).itemname            
            Set fitem=doc.GetFirstItem(fieldname)
            If view.Columns(x).title="文档号" Then    '自动生成的文档号处理        
                excelsheet.Cells(rows,cols).value=rows-1
            Else
                
                If Not (fitem Is Nothing) Then
                    excelsheet.Cells(rows,cols).value=fitem.Text 
                Else
                    excelsheet.Cells(rows,cols).value=""
                End If
            End If
            cols=cols+1
        Next
        rows=rows+1
        cols=1        
        Set doc=view.GetNextdocument(doc)
    Wend        
    excelapplication.statusbar="数据导入完成。"    
    Set excelapplication=Nothing
End Function