Lotus按时间段导出到EXCEL代码

  注意：本例中是 域 nian 存放时间    比较时一定要转化成文本型。

    在本例中，没有转化，但 nian设置的是文本域

Sub Initialize

       Dim s As New NotesSession

       Dim db As NotesDatabase

       Dim view As NotesView

       Dim doc As NotesDocument

       Dim exapp As Variant

       Dim exsheet As Variant

       Dim exworkbook  As Variant

       Dim docall As NotesDocumentCollection

      

       Set db=s.CurrentDatabase

       Set view=db.GetView("all")

      

       Set exapp=createobject("excel.application")

       exapp.referencestyle=2

       exapp.statusbar="正在计算导出Excel，请稍后..."

      

       exapp.workbooks.add

       Set exsheet=exapp.workbooks(1).worksheets(1)

       exsheet.name="Tip Top零件编码申请"

      

       Dim row As Integer

       Dim col As Integer

       Dim maxcol As Integer

       row=1

       col=1

       For x=0 To Ubound(view.Columns)

              If view.Columns(x).ishidden=False Then

                     If view.Columns(x).title<>"" Then

                            exsheet.cells(row,col).value=view.Columns(x).title

                     End If

                     col=col+1

              End If

       Next

       maxcol=col-1

       key1=Inputbox$("请输入要统计的月份开始日期,如:<st1:chsdate w:st="on" isrocdate="False" year="2006" day="1" islunardate="False" month="5">2006-05-01</st1:chsdate>","统计月份")

       key2=Inputbox$("请输入要统计的月份结束日期,如:<st1:chsdate w:st="on" isrocdate="False" year="2006" day="20" islunardate="False" month="5">2006-05-20</st1:chsdate>","统计月份")

       If Len(key1)<>10 Then

              Messagebox "输入的月份格式不对，请重新输入",,"提示"

              Exit Sub

       End If

             Dim filename As String

If Len(key2)<>10 Then

              Messagebox "输入的月份格式不对，请重新输入",,"提示"

              Exit Sub

       End If

       srchstring="SELECT Form = 'zhijumulu' & nian>='"+key1+"' & nian<='"+key2+"'"

       Set docall=db.Search(srchstring,Nothing,0)

       Dim coll As String

       coll=docall.Count

       If coll="" Then

              Messagebox "没有符合的记录，请确认输入条件是否正确",0,"警告"

              Exit Sub

       Else

              Messagebox "共有"+coll+"条符合要求的记录"

       End If

 

       Dim fitem As notesitem

       row=2

       col=1

       exapp.visible=True

       For i = 1 To coll

              Set doc= docall.getnthdocument(i)

              exapp.statusbar="正在从Notes里导出数据，可能要一段时间，请等候....."

              For j= 0 To Ubound(view.columns)

                     If view.columns(j).ishidden=False Then

                            If view.columns(j).title<>"" Then

                                   filename= view.columns(j).itemname

                                   Set fitem= doc.getfirstitem(filename)

                                   exsheet.cells(row,col).value= fitem.text

                                  

                            End If

                            col=col+1

                     End If    

              Next

              col=1

              row=row+1

              Set doc= docall.GetNthDocument(i)

       Next

      

       '格式化excel表

       exapp.rows("1:1").select

       exapp.selection.font.bold=True

       exapp.range(exsheet.cells(1,1),exsheet.cells(row,maxcol)).select

       exapp.selection.font.name="Arial"

       exapp.selection.font.size=9

       exapp.selection.columns.autofit

      

       exapp.referencestyle=1

       exapp.range("A1").select

       exapp.statusbar="数据导入完成"

      

End Sub