一段通过OLE将Notes View中的内容导入Excel的示范代码

Sub Click(Source As Button)
 '************************************************************
 '*这段代码用以导出当前视图下所有的内容,只限当前视图下的  *
 '*本代码摘自************************      *
 '*               *
 '*               *
 '************************************************************
      'Create an Excel Spreadsheet from any view
     '11/3/2000 Art Yates
 Dim Session As New NotesSession ,db As NotesDatabase
 Dim sourceview As NotesView,sourcedoc As NotesDocument
 Dim dataview As NotesView, dc As NotesDocumentCollection
 Dim datadoc As NotesDocument, maxcols As Integer
 Dim WS As New Notesuiworkspace
 Dim ViewString As String, Scope As String, GetField As Variant
 Dim C As NotesViewColumn, FieldName As String, K As Integer,N As Integer
 Dim xlApp As Variant, xlsheet As Variant, rows As Integer, cols As Integer
 Dim nitem As NotesItem , entry As NotesViewEntry, vwNav As NotesViewNavigator
 Dim ShowView()  As Variant, i As Integer, VList As Variant, ColVals As Variant
 
 Set db = session.CurrentDatabase   'link to current database
 
 'fetch then display a list of views in the database
 Vlist= db.views
 K=Ubound(Vlist)  'get size of list
 Redim Preserve ShowView(K)
 N=-1
 For i = 0 To K
  If Len(Vlist(i).Name) >0 Then 
   FieldName=Trim(Vlist(i).Name)
   If Mid(Fieldname,1,1) <>"(" Then  'do not show hidden views
    N=N+1    
    ShowView(N) = FieldName
   End If
  End If 
 Next i 
 Redim Preserve ShowView(N)
     'now sort the list - by default views are listing in the order that they were created
 For i=0 To N
  For K=i To N
   If  ShowView(i) > ShowView(k) Then
    FieldName=ShowView(i) 
    ShowView(i) = ShowView(k)
    ShowView(k)=FieldName
   End If
  Next k
 Next i 
 
 viewstring= ws.Prompt(PROMPT_OKCANCELLIST,"List of Views","Choose a View","",ShowView )
 If Len(viewstring)=0 Then Exit Sub
 'ViewString ="Dan's View"
 
 'Add comment by JS on 2007-7-23: below codes are extract data to excel.
 
 Set dataview = db.getview(ViewString)  'get selected view
 
 Set vwnav= dataview.createViewnav()
 
 rows = 1
 cols = 1
 maxcols=dataview.ColumnCount  'how many columns?
 
 Set xlApp = CreateObject("Excel.Application")  'start Excel with OLE Automation
 xlApp.StatusBar = "Creating WorkSheet. Please be patient..."
 xlApp.Visible = True
 xlApp.Workbooks.Add
 xlApp.ReferenceStyle = 2
 Set xlsheet = xlApp.Workbooks(1).Worksheets(1)   'select first worksheet
 
 'worksheet title
 xlsheet.Cells(rows,cols).Value ="View: " + ViewString + ", from Database: " +  db.title +",  Extract created on: " +  Format(Now,"mm/dd/yyyy HH:MM")
 
 xlApp.StatusBar = "Creating Column Heading. Please be patient..."
 
 rows=2  'column headings starts in row 2
 For K=1 To maxcols
  Set c=dataview.columns(K-1)
  xlsheet.Cells(rows,cols).Value = c.title
  cols = cols + 1
 Next K
 
 Set entry=vwnav.GetFirstDocument
 rows=3   'data starts in third row
 Do While Not (entry Is Nothing)
  
  For cols=1 To maxcols 
   colvals=entry.ColumnValues(cols-1) 'subscript =0
   scope=Typename(colvals)
   Select Case scope
   Case "STRING"
    xlsheet.Cells(rows,cols).Value ="'" +  colvals
   Case Else 
    xlsheet.Cells(rows,cols).Value = colvals
   End Select   
  Next cols  
  xlApp.StatusBar = "Importing Notes Data   -    Document " & rows-1 '& " of " & dc.count & "." 
  rows=rows+1
  Set entry = vwnav.getnextdocument(entry)  
 Loop
 
 xlApp.Rows("1:1").Select
 xlApp.Selection.Font.Bold = True
 xlApp.Selection.Font.Underline = True
 xlApp.Range(xlsheet.Cells(2,1), xlsheet.Cells(rows,maxcols)).Select
 xlApp.Selection.Font.Name = "Arial"
 xlApp.Selection.Font.Size = 9
 xlApp.Selection.Columns.AutoFit
 With xlApp.Worksheets(1)
  .PageSetup.Orientation = 2
  .PageSetup.centerheader = "Report - Confidential"
  .Pagesetup.RightFooter = "Page &P" & Chr$(13) & "Date: &D"
  .Pagesetup.CenterFooter = ""
 End With
 xlApp.ReferenceStyle = 1
 xlApp.Range("A1").Select
 xlApp.StatusBar = "Importing Data from Lotus Notes Application was Completed."
 'xlapp.ActiveWorkbook.saveas "c:VX" + Trim(Format(Now,"yyy"))   'save with generated name
 dataview.clear 
 
 Set xlapp=Nothing   'stop OLE
 Set db=Nothing
End Sub