WEB 下 View 导出到 Excel疑问

lotusfans

[转贴源码] WEB 下 View -> Excel

将下面的代码放入由Action触发的代理中，将会把View中的内容输出到Excel，而且可以保留大部分格式，如合计、分类等。而且速度飞快  ：）


        'Admin - New Export To Excel Script:
        Dim db                         As NotesDatabase
        Dim view                 As NotesView
        Dim doc                         As NotesDocument
        Dim tmpCount         As Integer
        Dim nmore, nc, nchar
        Dim session                 As New NotesSession
        Dim workspace         As New NotesUIWorkspace
        Dim strURL                 As String
        
        Set UIview                 = workspace.CurrentView
        Set db                         = session.CurrentDatabase
        UIViewname                 = UIView.ViewName
        UIViewAlias                 = UIView.Viewalias
        Set view                         = db.GetView( UIViewName )
        filePat                         = ReplaceSubstring(db.FilePath, "\", "/")
        
        'Get the common database name
        Dim nm As notesname
        Set nm = New notesname(db.server)
        
        'Get the view aliases
        If Not Isempty(view.Aliases) Then
                Forall aliass In view.Aliases
                        strViewAlias = aliass
                        Exit Forall
                End Forall
        Else
                Msgbox "No view aliases specified"
                Exit Function
        End If
        
        'Build the URL string
        strURL        =        "URL;http://" & nm.common & "/" & filepat & "/" & strViewAlias & "?openView"
        strURL1        =        strViewAlias & "?openView"
        
     'Launch Excel and open it in the UI
        Set excelAppObject                 = CreateObject("Excel.Application")
        excelAppObject.Visible         = True
        Call excelAppObject.Workbooks.Add
        Set excelWorksheetObject = excelAppObject.ActiveSheet
        
'        With ActiveSheet.QueryTables.Add(Connection:= "URL;http://lon-db-03/epsreq.nsf/1.%2 ... atus?OpenView" , Destination:=Range("A1"))
        With excelWorksheetObject.QueryTables.Add( strURL , excelWorksheetObject.Range("A1"))
                .Name =    strURL1                '"1.%20Authorisation%20Views%5Cc)%20All%20by%20Status?OpenView"
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = False
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlSpecifiedTables
                .WebFormatting = xlWebFormattingAll
                .WebTables = "2"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh 'BackgroundQuery:=False
        End With
        
        excelAppObject.Visible = False
        Messagebox "Export to Excel finished!", 64, db.title
        excelAppObject.Visible = True
        Exit Function
        
        
End Function

'The replacesunstring function was copied from a tip submitted on lotus website.Thanks to its developer.

Function ReplaceSubstring (fullString As String, oldString As String, newString As String) As String
        lenOldString = Len(oldString)
        position = Instr (fullString, oldString)
        Do While position > 0 And oldString <> ""
                fullString = Left(fullString, position -1) & newString & Mid (fullString, position + lenOldString)
                position = Instr (position + Len(newString), fullString, oldString)
        Loop
        ReplaceSubstring = fullString
End Function

lotusfans

我是因为单位使用合强公司开发的OA才接触到Lotus，因为实际应用中需要把视图的数据导出到Excel然后进行统计汇总，上面的这段代码可以解决这个问题，但是我不知道要如何使用，请高手指点！谢谢

moufuly

你的代码好乱，有点问题呢。
你确定是web上运行的，还是CS下，可以根据视图来生成一个web上可发布的excel?
因为这个代码中用了UI类，好象在web上直接用代理调用是不行的。

[本贴已被 moufuly 于 2004-2-4 15:00:37 修改过]

gdowc

?

lotusfans

非常感谢moufuly兄的热心帮助，我不熟悉Notes环境下的编程，这段代码是引自Lotus Notes中文技术论坛里的一篇贴子http://www.chinalotus.com/wyf/viewthread.php?tid=12736，可是我不知道要怎么用，心里好急！

lotusfans

视图---excel,表单---word[转贴]
《视图---Excel》也可作成后台代理
Sub Click(Source As Button)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim excelApplication As Variant
Dim excelWorkbook As Variant
Dim excelSheet As Variant
Dim i As Integer
&#39;---
Dim selection As Variant

Set excelApplication = CreateObject("Excel.Application"
excelApplication.Visible = True
&#39;找到Excel的位置
path = session.getenvironmentstring("directory",True)
gzpath=path+"\"+"th.xls"
&#39; execelApplication.Excel.open(gzpath)

Set excelWorkbook = excelApplication.Workbooks.Add
Set excelSheet = excelWorkbook.Worksheets("Sheet1"
&#39;定义Excel的列植
excelSheet.Cells(1,1).Value = "姓名"
excelSheet.Cells(1,2).Value = "年龄"

i = 1
Set db = session.CurrentDatabase
&#39;定义打印的视图
Set view = db.GetView("打印"
Set doc = view.GetFirstDocument
While Not(doc Is Nothing)
i = i + 1
&#39;定义域名为“姓名”
excelSheet.Cells(i,1).Value = doc.姓名(0)
excelSheet.Cells(i,2).Value = doc.年龄(0)
Set doc = view.GetNextDocument(doc)
Wend
&#39;选择a到d列
excelSheet.columns("a:d".select
&#39;excelSheet.Columns(A:g).Select
excelSheet.Columns("A:d".EntireColumn.AutoFit
&#39; excelSheet.Columns("A:d".EntireColumn.AutoFit
&#39;加上表格线
excelsheet.PageSetup.PrintGridlines = True
&#39;输出到打印机
excelWorkbook.printout

&#39;保存的位置，防止退出提问（可能可以用Excel的模版解决的更好）
excelWorkbook.SaveAs("Script 内容"
excelApplication.Quit
Set excelApplication = Nothing
End Sub

《表单---word》
Sub Click(Source As Button)
&#39; Sub print(printvar() As String,arrnum As Integer)
Dim session As New notessession
path =session.getenvironmentstring("Directory",True) &#39;notes工作路径
&#39;word application
Dim mark As String
Dim wordapp As Variant
Set wordapp=createobject("word.application"
wordapp.visible=True
wordapp.changefileopendirectory(path)
gzpath=path+"\"+"workpage.dot"
wordapp.documents.Open(gzpath)

Dim workspace As New notesuiworkspace
Dim uidoc As notesuidocument
Dim doc As notesdocument
Set uidoc = workspace.currentdocument
Set doc = uidoc.document

Dim printvar() As String
Dim arrnum As Variant
arrnum = 10
For i=1 To 2
&#39;在word中先定义书签，mark为书签名
mark=Trim("bookmark"+Trim(Str(i)))

wordapp.activedocument.bookmarks(mark).select
&#39;可改进下面一句，使得内容添近来
&#39; wordapp.wordbasic.insert(printvar(i))
wordapp.wordbasic.insert("test luck test 20"
Next
wordapp.Activedocument.printout
flag=Msgbox("工作票打印已经结束。",MB_OK,"提示"
If flag=1 Then
wordapp.activedocument.close(wdnotsavechanges)
wordapp.quit(wdnotsavechanges)
End If
&#39;End Sub
End Sub

lotusfans

再附一段同样功能的代码，可是不知道怎么用，好郁闷……
Sub Click(Source As Button)
Dim s As New notessession
Dim db As notesdatabase
Dim view As notesview
Dim dc As notesdocumentcollection
Dim doc As notesdocument
Dim vcols As Variant
Dim Uvcols As Integer
Set db = s.currentdatabase
Set dc = db.unprocesseddocuments
Set view = db.getview("PC\Lease Requests\Master"
Uvcols = Ubound(view.Columns)
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)
xlsheet.Name = "PC Lease "
Dim rows As Integer
rows = 1
Dim cols As Integer
cols = 1
Dim maxcols As Integer
For x=0 To Ubound(view.Columns)
xlApp.StatusBar = "Creating Cells and Creating Cell Headings. Please be patient..."
If view.Columns(x).IsHidden = False Then
If view.Columns(x).Title <> "" Then
xlsheet.Cells(rows,cols).Value = view.Columns(x).Title
cols = cols + 1
End If
End If
Next
maxcols = cols - 1

Set doc = dc.getfirstdocument
Dim fieldname As String
Dim fitem As notesitem
rows=2
cols=1

Do While Not (doc Is Nothing)
For x=0 To Ubound(view.Columns)
xlApp.StatusBar = "Importing Data from Lotus Notes Application. Please be patient..."
If view.Columns(x).IsHidden = False Then
If view.Columns(x).Title <> "" Then
fieldname = view.Columns(x).Itemname
Set fitem = doc.getFirstItem(fieldname)
xlsheet.Cells(rows,cols).Value = fitem.Text
cols = cols+1
End If
End If
Next
rows = rows+1
cols =1
Set doc = dc.getnextdocument(doc)
Loop
xlApp.Rows("1:1".Select
xlApp.Selection.Font.Bold = True
xlApp.Range(xlsheet.Cells(1,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."
End Sub

zj_1

请教: 如何将excel 导入LOTUS中？