Lotus中导出到EXCEL代码,Domino代码库,德仔网

代码语言
代码分类
【Domino】 Lotus中导出到EXCEL
作者:entry / 发布于2014/7/25/ 1586

	Dim ss As NotesSession
	Dim db As NotesDatabase
	Dim doc As NotesDocument
	Dim docContext As NotesDocument
	Dim view As NotesView

	

	Sub Initialize
	On Error Goto Terminate
	Set ss=New NotesSession
	Set docContext=ss.DocumentContext
	Set db = ss.CurrentDatabase
	Dim dbName As String
	Dim category As String
	Dim viewName As String
	Dim path As String
	Dim title As String
	path=ss.GetEnvironmentString("Directory",True)
	dbName=GetParaValue(docContext.Query_String_Decoded(0),"DbName","")
	category=GetParaValue(docContext.Query_String_Decoded(0),"Category","")
	viewName=GetParaValue(docContext.Query_String_Decoded(0),"View","")
	Set db = ss.GetDatabase("", dbName)
	Set view = db.GetView( viewName)
	Dim xlApp As Variant
	Dim xlsheet As Variant
	 '创建一个Excel对象
	Set xlApp = CreateObject("excel.application")
	xlApp.statusbar = "正在创建工作表，请稍等......"
	xlApp.visible = True
	 '添加工作薄
	xlApp.workbooks.add
	xlApp.referencestyle = 2
	Set xlsheet = xlapp.workbooks(1).worksheets(1)
	 '为工作表命名
	If viewName Like "*Asset*" Or viewName="gdzcCard" Then
	 xlsheet.name = "固定资产"+category
	Else
	 xlsheet.name = "低值易耗品"+category
	End If
	'xlsheet.name = category
	On Error Goto Terminate
	
	'************************************画表头*********************************
	
	'工作记录单汇总表
	xlApp.Range("A1:J1").Select
	xlApp.selection.Merge
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "康书" '字体
	xlApp.selection.Font.size = "13" '大小
	xlApp.selection.Font.Bold =True '加粗
	xlApp.ActiveCell.FormulaR1C1 = category
	
	'日期
	xlApp.Range("A2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="5"
	xlApp.ActiveCell.FormulaR1C1 = "序号"
	
	'日期
	xlApp.Range("B2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "品名"
	
	'日期
	xlApp.Range("C2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "购买日期"
	
	
	
	'日期
	xlApp.Range("D2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "规格型号"
	
	
	 '日期
	xlApp.Range("E2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	
	xlApp.ActiveCell.FormulaR1C1 = "金额"
	
	
	
	 '日期
	xlApp.Range("F2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "状况"
	
	
	 '日期
	xlApp.Range("G2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "部门"
	
	
	
	 '日期
	xlApp.Range("H2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "最后使用人"
	
	
	
	
	 '日期
	xlApp.Range("I2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "科目代号凭证"
	
	xlApp.Range("j2").Select
	xlApp.selection.Merge
	xlApp.selection.font.size="10"
	xlApp.selection.Font.Bold =True
	xlApp.selection.HorizontalAlignment =3 '左右居中
	xlApp.selection.VerticalAlignment=2 '上下居中
	xlApp.selection.Font.name = "宋体" '字体
	xlApp.selection.columnwidth="15"
	xlApp.ActiveCell.FormulaR1C1 = "备注"
	'************************************画表头*********************************
	
	Dim rows As Integer
	Dim cols As Integer
	rows = 3
	Dim text As Variant
	If viewName Like "*Asset*" Or viewName="gdzcCard" Then
	 If category="全部" Or category="未分类" Then
	 Set doc = view.GetFirstDocument
	 While Not doc Is Nothing
	 xlApp.statusbar = "正在导出数据，请稍等......"
	 xlsheet.Cells(rows,1).Value = rows-2
	 xlsheet.Cells(rows,2).Value = doc.Name(0)
	 xlsheet.Cells(rows,3).Value = doc.Date_Shop(0)
	 xlsheet.Cells(rows,4).Value = doc.Model(0)
	 xlsheet.Cells(rows,5).Value = doc.Amount(0)
	 xlsheet.Cells(rows,6).Value = doc.Using_Last(0)
	 xlsheet.Cells(rows,7).Value = doc.Keep_Dept(0)
	 xlsheet.Cells(rows,8).Value = doc.Keeper(0)
	 xlsheet.Cells(rows,9).Value = doc.CardH(0)
	 xlsheet.Cells(rows,10).Value = doc.P_Rem(0)
	 rows=rows +1
	 xlapp.statusbar = "总共导出数据" & rows-1 & "，导出完成!"
	 Set doc = view.GetNextDocument(doc)
	 Wend
	 Else
	 Dim dc As NotesDocumentCollection
	 Set dc = view.GetAllDocumentsByKey(category, True)
	 Set doc = dc.GetFirstDocument
	 While Not doc Is Nothing
	 xlApp.statusbar = "正在导出数据，请稍等......"
	 xlsheet.Cells(rows,1).Value = rows-2
	 xlsheet.Cells(rows,2).Value = doc.Name(0)
	 xlsheet.Cells(rows,3).Value = doc.Date_Shop(0)
	 xlsheet.Cells(rows,4).Value = doc.Model(0)
	 xlsheet.Cells(rows,5).Value = doc.Amount(0)
	 xlsheet.Cells(rows,6).Value = doc.Using_Last(0)
	 xlsheet.Cells(rows,7).Value = doc.Keep_Dept(0)
	 xlsheet.Cells(rows,8).Value = doc.Keeper(0)
	 xlsheet.Cells(rows,9).Value = doc.CardH(0)
	 xlsheet.Cells(rows,10).Value = doc.P_Rem(0)
	 rows=rows +1
	 xlapp.statusbar = "总共导出数据" & rows-1 & "，导出完成!"
	 Set doc = dc.GetNextDocument(doc)
	 Wend
	 End If
	Else
	 If category="全部" Or category="未分类" Then
	 Set doc = view.GetFirstDocument
	 While Not doc Is Nothing
	 xlApp.statusbar = "正在导出数据，请稍等......"
	 xlsheet.Cells(rows,1).Value = rows-2
	 xlsheet.Cells(rows,2).Value = doc.Name(0)
	 xlsheet.Cells(rows,3).Value = doc.Date_Shop(0)
	 xlsheet.Cells(rows,4).Value = doc.Model(0)
	 xlsheet.Cells(rows,5).Value = doc.Sum(0)
	 xlsheet.Cells(rows,6).Value = doc.State(0)
	 If doc.Keep_Dept(0)<>"" Then
	 xlsheet.Cells(rows,7).Value = doc.Keep_Dept(0)
	 Else
	 xlsheet.Cells(rows,7).Value = doc.Use_Dept_Last(0)
	 End If
	 If doc.User_Last(0)<>"" Then
	 xlsheet.Cells(rows,8).Value = doc.User_Last(0)
	 Else
	 xlsheet.Cells(rows,8).Value = doc.Keeper(0)
	 End If
	 xlsheet.Cells(rows,9).Value = doc.CardH(0)
	 xlsheet.Cells(rows,10).Value = doc.P_Rem(0)
	 rows=rows +1
	 xlapp.statusbar = "总共导出数据" & rows-1 & "，导出完成!"
	 Set doc = view.GetNextDocument(doc)
	 Wend
	 Else
	 Dim dc1 As NotesDocumentCollection
	 Set dc1 = view.GetAllDocumentsByKey(category, True)
	 Set doc = dc1.GetFirstDocument
	 While Not doc Is Nothing
	 xlApp.statusbar = "正在导出数据，请稍等......"
	 xlsheet.Cells(rows,1).Value = rows-2
	 xlsheet.Cells(rows,2).Value = doc.Name(0)
	 xlsheet.Cells(rows,3).Value = doc.Date_Shop(0)
	 xlsheet.Cells(rows,4).Value = doc.Model(0)
	 xlsheet.Cells(rows,5).Value = doc.Sum(0)
	 xlsheet.Cells(rows,6).Value = doc.State(0)
	 If doc.Keep_Dept(0)<>"" Then
	 xlsheet.Cells(rows,7).Value = doc.Keep_Dept(0)
	 Else
	 xlsheet.Cells(rows,7).Value = doc.Use_Dept_Last(0)
	 End If
	 If doc.User_Last(0)<>"" Then
	 xlsheet.Cells(rows,8).Value = doc.User_Last(0)
	 Else
	 xlsheet.Cells(rows,8).Value = doc.Keeper(0)
	 End If
	 xlsheet.Cells(rows,9).Value = doc.CardH(0)
	 xlsheet.Cells(rows,10).Value = doc.P_Rem(0)
	 rows=rows +1
	 xlapp.statusbar = "总共导出数据" & rows-1 & "，导出完成!"
	 Set doc = dc1.GetNextDocument(doc)
	 Wend
	 End If
	End If
	'*************对导出数据进行排序****************
	xlApp.Range("B3:J"&rows).Select
	Call xlApp.Selection.Sort(xlApp.Range("b4"), 1)
	'******************结束排序*****************
	Msgbox xlapp.statusbar
	printXML "OK"
	xlApp.ActiveWorkbook.SaveCopyAs path+"\domino\html\ExportEXCEL.xls"
	
	'Print |<script language="javascript">|
	'Print |var pathname=window.location.href;|
	 'Print |alert(pathname);|
	'Print |var serverUrl=pathname.substring(0,pathname.lastIndexOf('HQTS'));|
	'Print |window.open(path+"\导出的EXCEL.xls");|
	'Print |history.back();|
	'Print |</script>|
	Terminate:
	xlApp.DisplayAlerts = False
	xlApp.Quit ' 关闭Excel
	Set xlApp = Nothing '释放空间
	Msgbox Error & "|" & Erl
	ErrLog "删除文档|DeleteDocument"
	Exit Sub
	End Sub
试试其它关键字
　导出到EXCEL　
同语言下
可能有用的
entry贡献的其它代码(10)