Sub Click(Source As Button)
On Error Goto ErrorHandle
Dim workspace As New NotesUIWorkspace
Dim Session As New NotesSession
Dim uidoc As notesuidocument
Dim db As NotesDatabase
Dim view As notesview
Dim viewt5sub As NotesView
Dim dc As NotesDocumentCollection
Dim dcKzd As NotesDocumentCollection
Dim doc As notesdocument
Dim docKzd As notesdocument
Dim profile As notesdocument
Dim item As notesitem
Dim itema As notesitem
Dim rtitem As Variant
Set db = session.CurrentDatabase
Set uidoc = workspace.CurrentDocument
Set doc = uidoc.Document
Set viewt5sub = db.GetView("ExportT5")
Set dc = viewt5sub.GetAllDocumentsByKey(doc.bmgwqdbdocid(0),True)
If dc.count = 0 Then
Msgbox "没有数据,不能执行导出！",16,"提示"
Exit Sub
Else
Print "开始导出..."
Dim floder As String
floder = "c:/报表"
If Dir$(floder,16) = "" Then
Mkdir floder
End If
'------------------------------------------------------------
'得到excel模板----------------------------------------------
Dim dba As New NotesDatabase(db.Server,"excelmb/mb.nsf")
Set exview = dba.GetView("Report")
Call exview.refresh
Set exdc = exview.GetAllDocumentsByKey("Table",True)
If exdc.count>0 Then
Set exdoc = exdc.getfirstdocument
If Not exdoc Is Nothing Then
Set rtitem = exdoc.GetFirstItem("ReportBody")
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Call o.ExtractFile( "c:/Table.xls")
End If
End Forall
End If
End If
End If
'得到excel模板----------------------------------------------
'产生Excel文件
Set excelApplication = CreateObject("excel.Application")
Set excelWorkbook = excelApplication.Workbooks.add("c:/Table.xls")
Set excelSheet = excelWorkbook.Worksheets("Sheet1")
'导出文档
Set docKzd = dc.GetFirstDocument()
i = 6
While Not(docKzd Is Nothing)
bumen = doc.bumen(0)
subject = bumen
zxrgw = doc.kzd_zrr(0)
docflag = doc.bmgwqdbdocid(0)
pgsjfw = Cstr(doc.pgfw1(0))+"～"+Cstr(doc.pgfw2(0))
fzflow = doc.showflow
excelSheet.Cells(1,1).Value = docflag
excelSheet.Cells(2,1).Value = doc.UniversalID
excelSheet.Cells(1,2).Value = subject
excelSheet.Cells(4,2).Value = zxrgw
excelSheet.Cells(4,7).Value = pgsjfw
excelSheet.Cells(3,3).Value = doc.YgCode(0)
excelSheet.Cells(i,1).Value = docKzd.UniversalID
excelSheet.Cells(i,2).Value = docKzd.xzmc(0)
excelSheet.Cells(i,3).Value = docKzd.kzdbh(0)
excelSheet.Cells(i,4).Value = docKzd.a_kongzhidianmin(0)
excelSheet.Cells(i,5).Value = docKzd.ygzpjl(0)
excelSheet.Cells(i,6).Value = docKzd.qxxz(0)
excelSheet.Cells(i,7).Value = docKzd.qxms(0)
excelSheet.Cells(i,8).Value = docKzd.zxqxcsyy(0)
excelSheet.Cells(i,9).Value = docKzd.sjje(0)
excelSheet.Cells(i,10).Value = docKzd.qzyx(0)
excelSheet.Cells(i,11).Value = docKzd.zxgjcs(0)
excelSheet.Cells(i,12).Value = Cstr(docKzd.wcsj(0))
'给excel加边框
excelSheet.cells(i,2).Borders.LineStyle = 1
excelSheet.cells(i,3).Borders.LineStyle = 1
excelSheet.cells(i,4).Borders.LineStyle = 1
excelSheet.cells(i,5).Borders.LineStyle = 1
excelSheet.cells(i,6).Borders.LineStyle = 1
excelSheet.cells(i,7).Borders.LineStyle = 1
excelSheet.cells(i,8).Borders.LineStyle = 1
excelSheet.cells(i,9).Borders.LineStyle = 1
excelSheet.cells(i,10).Borders.LineStyle = 1
excelSheet.cells(i,11).Borders.LineStyle = 1
excelSheet.cells(i,12).Borders.LineStyle = 1
i = i + 1
Set docKzd = dc.GetNextDocument(docKzd)
Wend
Kill "c:/Table5.xls"
newfilename = floder+"/"+doc.kzd_zrr(0)+"("+Cstr(Format(Now, "yyyymmddhhhmmss"))+")"
excelworkbook.Saveas(newfilename)
excelapplication.Quit
Set excelapplication = Nothing
Msgbox "导出成功，请在【C:/报表】文件夹下查看！"
End If
Exit Sub
ErrorHandle:
Msgbox Cstr(Erl()) + "....." + Error(),16,"提示"
excelapplication.Quit
Set excelapplication = Nothing
Exit Sub
End Sub
