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