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
已经设置好保存路径,保存之后删除原来的文档,并嵌入表单中
lotus生成excel(一)
最新推荐文章于 2022-11-24 15:04:00 发布