lotus生成excel(一)

Sub Click(Source As Button)
	On Error Goto errHandler
	Dim ws As New NotesUIWorkspace
	Dim uidoc As NotesUIDocument
	Dim doc As NotesDocument
	Dim db As NotesDatabase
	Dim view As NotesView
	Dim dc As NotesDocumentCollection
	Dim entry As NotesViewEntry
	Dim vc As NotesViewEntryCollection
	
	Set uidoc = ws.CurrentDocument
	Set doc = uidoc.Document
	Set db = doc.ParentDatabase
	uidoc.EditMode = True
	
	If Cstr(doc.datTJ(0)) = "" Then
		Msgbox "请填写统计时间",48,"提示"  
		uidoc.GotoField("datTJ")  
		Exit Sub	
	End If
	
	'判断是否已经存在excel
	Dim rtfitem As NotesRichTextItem  
	Set rtfitem = doc.GetFirstItem("rtfExcel")  
	Dim txt As String  
	txt$ = uidoc.FieldGetText("rtfExcel")  
	trimmed$ = Trim(txt$)  
	If doc.HasEmbedded Then  
		Msgbox "请先删除统计表",48,"提示"  
		uidoc.GotoField("rtfExcel")  
		Exit Sub	
	End If 
	
	'生成excel模版
	Dim title As String
	title = Year(doc.datTJ(0)) & "年" & Month(doc.datTJ(0)) & "月" & "证件使用统计表"
	Dim fn As String
	fn = "d:\证件统计表.xls"
	
	Dim keys(1) As String
	keys(0) = Year(doc.datTJ(0))
	keys(1) = Month(doc.datTJ(0)) 
	
	Set view = db.GetView("(证件使用统计)")
	Set dc = view.GetAllDocumentsByKey(keys)
	
	Dim xlApp As Variant
	Dim xlWorkBook As Variant
	Dim xlSheet As Variant
	
	Set xlApp = createObject("excel.application")
	xlApp.visible = False
	
	
	Select Case Val(xlApp.application.Version)
	Case 5
		myVersion = "5.0"
	Case 7
		myVersion = "95"
	Case 8
		myVersion = "97"
	Case 9
		myVersion = "2000"
	Case 10
		myVersion = "2002"
	Case 11
		myVersion = "2003"
	Case 12
		myVersion = "2007"
	Case 14
		myVersion = "2010"
	Case Else
		myVersion = "版本不明"
	End Select
	
	Dim txtName As String
	Dim numL As String
	
	Set xlWorkBook = xlApp.WorkBooks.Add
	
	Dim pdoc As NotesDocument
	
	Set xlSheet = xlWorkBook.Sheets(1)
	xlSheet.name = Month(doc.datTJ(0))
	With xlSheet
		
		.cells(1,1) = title
		.cells(2,1) = "证件编号"
		.cells(2,2) = "证件类别"
		.cells(2,3) = "证件名称"
		.cells(2,4) = "借用日期"
		.cells(2,5) = "借用人"
		.cells(2,6) = "借用原因"
		.cells(2,7) = "归还日期"
		.Range(.Cells(1,1),.Cells(1,7)).merge(False)
		
		
		.Rows(1).font.size=18
		.Rows(2).font.size=10
		.Rows(1).font.Bold=True
		.Rows(2).font.Bold=True
		
		.Rows(1).HorizontalAlignment=3
		.Rows(1).RowHeight=23.25
		.Rows(2).HorizontalAlignment=3
		.Rows(2).RowHeight=13.5
	
		.Cells(2,1).HorizontalAlignment=3
		.Cells(2,2).HorizontalAlignment=3	
		.Cells(2,3).HorizontalAlignment=3
		.Cells(2,4).HorizontalAlignment=3
		.Cells(2,5).HorizontalAlignment=3
		.Cells(2,6).HorizontalAlignment=3
		.Cells(2,7).HorizontalAlignment=3
		
		.Cells(2,1).font.Bold=True
		.Cells(2,2).font.Bold=True
		.Cells(2,3).font.Bold=True
		.Cells(2,4).font.Bold=True
		.Cells(2,5).font.Bold=True
		.Cells(2,6).font.Bold=True
		.Cells(2,7).font.Bold=True
		
		row = 3
		
		Set pdoc = dc.GetFirstDocument
		While Not(pdoc Is Nothing)
			.Cells(row,1) = pdoc.txtNo(0)
			.cells(row,2) = pdoc.txtType(0)
			.cells(row,3) = pdoc.txtName(0)
			.cells(row,4) = pdoc.datBorrowDate(0)
			.cells(row,5) = pdoc.txtApplicantName(0)
			.Cells(row,6) = pdoc.txtReason(0)
			.cells(row,7) = pdoc.datReturnDate(0)
			
			.Rows(row).font.size=9
			.Rows(row).HorizontalAlignment=3
			.cells(row,1).HorizontalAlignment=-4131'左对齐
			.cells(row,2).HorizontalAlignment=-4131
			
			row = row + 1
			Set pdoc = dc.GetNextDocument(pdoc)
		Wend
		
		.Columns(6).ColumnWidth = 23.63
		.Columns(3).ColumnWidth = 19.13
		
	End With
	
	If myVersion="2007" Or myVersion="2010" Then
		Call xlWorkbook.saveas(fn,56,"","",False,False)
	Else
		Call xlWorkbook.saveas(fn)
	End If
	
	xlWorkbook.Close False 
	Set xlWorkbook = Nothing
	Call xlApp.Quit()
	Set xlApp = Nothing
	
	'生成Excel模板文件
	'doc.txtFlag="1"		
	doc.form="证件统计表"
	doc.saveoptions="0"		
	Dim rtitem As NotesRichTextItem
	Set rtitem = New NotesRichTextItem(doc,"rtfExcel")		
	Call rtitem.EmbedObject(EMBED_ATTACHMENT, "", fn)
	Call uidoc.reload
	Call doc.ComputeWithForm( False, False )	
	Call uidoc.Close
	
	Kill fn
	
	Set uidoc = ws.EditDocument(True,doc)
	
	Call uidoc.reload
	Call uidoc.refresh
getOut:
	Exit Sub
errHandler:
	Msgbox Error$ & " (" & Err & " at line " & Erl & ")",,"Error"  
	Resume getOut
End Sub
           

已经设置好保存路径，保存之后删除原来的文档，并嵌入表单中