lotus客户端导出Excel

Option Public
Option Declare

Sub Initialize
	On Error GoTo Errhandle
	Dim ss As New NotesSession
	Dim db As NotesDatabase
	Dim view As NotesView
	Dim docs As NotesDocumentCollection
	Dim tdoc As NotesDocument
	Dim ventry As NotesViewEntry
	Dim vns As NotesViewEntryCollection
	
	
	Set db=ss.Currentdatabase
	Set view=db.Getview("viewArcDocForExcel")
	Set docs=view.Getalldocumentsbykey("请假申请", 1)
	
	Set tdoc =docs.Getfirstdocument()

	
	Dim excelApp As Variant
	Dim excelSheet As Variant
	Set excelApp=CreateObject("excel.application")
	excelApp.statusbar="正在创建工作表，请稍等......"
	excelApp.visible=False
	excelApp.workbooks.Add
	'excelApp.Visible = True
	excelApp.referencestyle=2
	Set excelSheet=excelApp.workbooks(1).worksheets(1)
	excelSheet.name="请假统计"

	'增加标题
	excelApp.Range("A1:D1").Select        '指定列的范围   
    excelApp.selection.Merge   
    excelApp.selection.Rows.Rows(1).RowHeight=40 
	excelApp.selection.HorizontalAlignment =3     '左右居中 
	excelApp.selection.VerticalAlignment=2         '上下居中 
	excelApp.selection.Font.name = "康书"           '字体 
	excelApp.selection.Font.size = "18"            '大小  
	excelApp.selection.Font.Bold =True            '加粗   
	excelApp.ActiveCell.FormulaR1C1 = "请假统计表"    '赋值 

	excelApp.Range("A2").Select  
	excelApp.selection.Merge   
	excelApp.selection.font.size="10" 
	excelApp.selection.RowHeight=27 
	excelApp.selection.Font.Bold =True 
	excelApp.selection.HorizontalAlignment =3 '左右居中
	excelApp.selection.VerticalAlignment=2  '上下居中
	excelApp.selection.Font.name = "宋体"  '字体
	excelApp.selection.columnwidth="10"  '当前列宽
	excelApp.selection.RowHeight=27  '  当前行高
	excelApp.ActiveCell.FormulaR1C1 = "请假类型"  '赋值
	excelApp.selection.Interior.ColorIndex= 55  '表格底色55表示深蓝色
	excelApp.selection.font.ColorIndex= 2  '字体颜色2表示白色
	excelApp.Selection.Borders.LineStyle = 1 '线格

	excelApp.Range("B2").Select  
	excelApp.selection.Merge   
	excelApp.selection.font.size="10" 
	excelApp.selection.RowHeight=27 
	excelApp.selection.Font.Bold =True 
	excelApp.selection.HorizontalAlignment =3 '左右居中
	excelApp.selection.VerticalAlignment=2  '上下居中
	excelApp.selection.Font.name = "宋体"  '字体
	excelApp.selection.columnwidth="10"  '当前列宽
	excelApp.selection.RowHeight=27  '  当前行高
	excelApp.ActiveCell.FormulaR1C1 = "请假类型"  '赋值
	excelApp.selection.Interior.ColorIndex= 55  '表格底色55表示深蓝色
	excelApp.selection.font.ColorIndex= 2  '字体颜色2表示白色
	excelApp.Selection.Borders.LineStyle = 1 '线格
	
	excelApp.Range("C2").Select  
	excelApp.selection.Merge   
	excelApp.selection.font.size="10" 
	excelApp.selection.RowHeight=27 
	excelApp.selection.Font.Bold =True 
	excelApp.selection.HorizontalAlignment =3 '左右居中
	excelApp.selection.VerticalAlignment=2  '上下居中
	excelApp.selection.Font.name = "宋体"  '字体
	excelApp.selection.columnwidth="10"  '当前列宽
	excelApp.selection.RowHeight=27  '  当前行高
	excelApp.ActiveCell.FormulaR1C1 = "请假天数"  '赋值
	excelApp.selection.Interior.ColorIndex= 55  '表格底色55表示深蓝色
	excelApp.selection.font.ColorIndex= 2  '字体颜色2表示白色
	excelApp.Selection.Borders.LineStyle = 1 '线格
	
	excelApp.Range("D2").Select  
	excelApp.selection.Merge   
	excelApp.selection.font.size="10" 
	excelApp.selection.RowHeight=27 
	excelApp.selection.Font.Bold =True 
	excelApp.selection.HorizontalAlignment =3 '左右居中
	excelApp.selection.VerticalAlignment=2  '上下居中
	excelApp.selection.Font.name = "宋体"  '字体
	excelApp.selection.columnwidth="10"  '当前列宽
	excelApp.selection.RowHeight=27  '  当前行高
	excelApp.ActiveCell.FormulaR1C1 = "请假日期"  '赋值
	excelApp.selection.Interior.ColorIndex= 55  '表格底色55表示深蓝色
	excelApp.selection.font.ColorIndex= 2  '字体颜色2表示白色
	excelApp.Selection.Borders.LineStyle = 1 '线格

	
	Dim rows As Integer
	rows=3
	
	
	
	While Not tdoc Is Nothing 
		excelSheet.Cells(rows,1).value=tdoc.AddName(0)
		excelSheet.Cells(rows,2).value=tdoc.qjlx(0)
		excelSheet.Cells(rows,3).value=tdoc.hjts(0)
		excelSheet.Cells(rows,4).value=CStr(tdoc.DocPostTime(0))
		Set tdoc=docs.Getnextdocument(tdoc)
		rows=rows +1
	Wend
	excelSheet.Columns("A:D").EntireColumn.AutoFit
	excelApp.statusbar="就绪"
	excelApp.ActiveWorkbook.SaveCopyAs("D:\zb.xls")
	excelApp.DisplayAlerts = False 
	excelApp.Quit 
	Set excelApp = Nothing
	Exit sub
Errhandle:
	print Error 	& CStr(Erl)
	
End Sub