Lotus 导出Excel

Sub Click(Source As Button)
 On Error Goto p
 Dim ws As New NotesUIWorkspace
 Dim uidoc As NotesUIDocument
 Dim s As New NotesSession
 Dim db As NotesDatabase
 Dim ajDC As NotesDocumentCollection
 Dim ajDoc As NotesDocument
 
 Dim larq As String '立案日期
 Dim formula As String
 Const path2Save = "E:\立案统计报表" '存储路径
 Dim ygBuff  As String '原告信息
 Dim bgBuff As String '被告信息
 Dim mcArray As Variant
 Dim dwArray As Variant '地位
 Dim dhArray As Variant '电话
 
 Dim  rowBegin As Integer
 Dim ii As Integer
 Dim xlsApp As Variant 'Excel对象
 
 Set xlsApp = CreateObject("Excel.application")
 If Not(xlsApp Is Nothing) Then
  '在这个 Excel 文件当中添加一个 Sheet
  xlsApp.Workbooks.Add
  xlsApp.Visible = True
  ii = 1
  rowBegin = 1
  xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 1).Value = "序号"
  xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 2).Value = "案号"
  xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 3).Value = "案件类型"
  xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 4).Value = "原告信息"
  xlsApp.Workbooks(1).Worksheets( 1 ).Cells( rowBegin , 5).Value = "被告信息"
  REM 导出数据至Excel
  Set uidoc = ws.CurrentDocument
  larq = Format(uidoc.FieldGetText("LARQ"),"yyyy年mm月dd日")
  Set db = s.CurrentDatabase
  formula = "(Form = 'Mostly')& (LARQ='"+larq+"')"
  Set ajDC = db.Search(formula,Nothing,0)
  Set ajDoc = ajDC.GetFirstDocument
  While Not(ajDoc Is Nothing)
   ygBuff = ""
   bgBuff = ""
   mcArray = Split(ajDoc.MC(0),"|")
   dhArray = Split(ajDoc.LXDH(0),"|")
   If(ajDoc.HasItem("DW"))Then
    dwArray = Split(ajDoc.DW(0),"|")
    For index = 0 To Ubound(dwArray)
     If("原告" = dwArray(index) Or "申请人" = dwArray(index))Then
      ygBuff = ygBuff + mcArray(index) + "##" + Trim(dhArray(index)) + "；"
     Else
      If("被告" = dwArray(index) Or "被申请人" = dwArray(index))Then
       bgBuff = bgBuff + mcArray(index) + "##" + Trim(dhArray(index)) + "；"
      End If
     End If
    Next
   Else
    For index = 0 To Ubound(mcArray)
     bgBuff = bgBuff + mcArray(index) + "##" + Trim(dhArray(index)) + "；"
    Next
   End If
   
   rowBegin = ii + 1
   xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 1).Value = Cstr(ii)
   xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 2).Value = ajDoc.AH(0)
   xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 3).Value = ajDoc.ajlx(0)
   xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 4).Value = ygBuff
   xlsApp.Workbooks(1).Worksheets( 1 ).Cells(rowBegin , 5).Value = bgBuff
   Set ajDoc = ajDC.GetNextDocument(ajDoc)
   ii = ii + 1
  Wend
  xlsApp.Workbooks(1).Worksheets(1).Columns("A:E").EntireColumn.AutoFit
  If(Dir(path2Save,16) = "")Then '检查目录是否已经存在
   Mkdir(path2Save)
  End If
  xlsApp.ActiveWorkbook.SaveAs( path2Save+"\"+larq+".xls")
      '关闭资源
  xlsApp.Quit
          '资源释放
  Set xlsApp = Nothing
  'Msgbox("报表已经生成！")
  '打开报表
  ws.URLOpen(path2Save+"\"+larq+".xls")
 End If
 
 Exit Sub
p:
 Msgbox(Erl())
End Sub