[Lotus]如何把视图导出到E
Sub WriteToExcel
'本字程序功能为写入数据到指定的Excel文件里,用户选定的文档将被输出。
'[处理视图]-初始化视图
Dim ws As New NotesUIWorkspace
Dim uiView As NotesUIView
Dim View As NotesView
Dim col As NotesViewColumn
Dim s As New NotesSession
Dim db As NotesDatabase
Dim cl As NotesDocumentCollection
Set uiView = ws。 CurrentView
Set View ...全部
Sub WriteToExcel
'本字程序功能为写入数据到指定的Excel文件里,用户选定的文档将被输出。
'[处理视图]-初始化视图
Dim ws As New NotesUIWorkspace
Dim uiView As NotesUIView
Dim View As NotesView
Dim col As NotesViewColumn
Dim s As New NotesSession
Dim db As NotesDatabase
Dim cl As NotesDocumentCollection
Set uiView = ws。
CurrentView
Set View = uiView。View
Set db = s。CurrentDatabase
Set cl = db。UnprocessedDocuments
'初始化Excel对象
Dim xlApp As Variant
Dim xlsheet As Variant
Set xlApp = CreateObject("Excel。
application")
xlApp。StatusBar = "Creating WorkSheet。 Please be patient。。。"
xlApp。Visible = True
xlApp。
Workbooks。Add
xlApp。ReferenceStyle = 2
Set xlsheet = xlApp。Workbooks(1)。Worksheets(1)
'[处理视图]-读取列名
Dim ReadColumnTitle() As String
Redim ReadColumnTitle(0 To Ubound(View。
Columns)) As String
For i = 0 To Ubound(View。Columns)
ReadColumnTitle(i)=View。Columns(i)。title
Next
Call WriteToExcelRow("A",2,xlsheet,ReadColumnTitle)
'[处理视图]-读取内容
Dim tDoc As NotesDocument
Dim ReadViewResult
Dim j As Integer
Set tDoc = cl。
GetFirstDocument
j=3
While Not tDoc Is Nothing
ReadViewResult = ReadRow(View,tDoc)
Call WriteToExcelRow("A",j,xlsheet,ReadViewResult)
Set tDoc = cl。
GetNextDocument(tDoc)
j=j+1
Wend
'保存文件
xlApp。Rows("2:1")。Select
xlApp。Selection。
Font。Bold = True
xlApp。Selection。Font。Underline = True
xlApp。Range(xlsheet。Cells(1,1), xlsheet。
Cells(j,Ubound(View。Columns)+1))。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。"
End Sub
Function ReadRow( tView As NotesView , tDoc As NotesDocument ) As Variant
'该函数为把视图中某定位文档的所有视图显示值放入一个ReadRow的数组里,tView为所要操作的视图,tDoc为所定位的文档
Dim tResultArray() As String
tLength% = Ubound(tView。
Columns)
Redim tResultArray(0 To tLength%) As String
For i = 0 To Ubound(tView。Columns)
Set col = tView。
Columns(i)
tValue$ = col。ItemName
vFormula$ = col。Formula
If col。Formula ="" Then
vResult = Evaluate(tValue$,tDoc)
Else
vResult = Evaluate(vFormula$,tDoc)
End If
tResultArray(i) = vResult(0)
Next
ReadRow = tResultArray
End Function
Sub WriteToExcelRow( tR As String,tC As Integer,xlsheet As Variant,tValue As Variant)
With xlsheet
For i = 0 To Ubound(tValue)
tLoca=Chr(Asc(tR)+i)+Cstr(tC)
。
Range(tLoca)。Value = tValue(i)
Next
End With
End Sub。收起