数据导出(Lotus Notes)

导出到excel中
Sub Click(Source As Button)
Dim s As New notessession
Dim db As notesdatabase
Dim view As notesview
Dim dc As notesdocumentcollection
Dim doc As notesdocument
Dim vcols As Variant
Dim uvcols As Integer

Set db = s.currentdatabase
Set dc = db.unprocesseddocuments
Set view = db.getview("当前视图的名称 ")
uvcols=Ubound(view.columns)

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)
'为工作表命名
xlsheet.name = "notes export"
Dim rows As Integer
rows = 1
Dim cols As Integer
cols = 1
Dim maxcols As Integer
For x=0 To Ubound(view.columns)
xlapp.statusbar = "正在创建单元格，请稍等...... "
If view.columns(x).IsHidden = False Then
   If view.columns(x).title<>"" Then
    xlsheet.cells(rows,cols).value = view.columns(x).title
    cols = cols + 1
   End If
End If
Next
maxcols=cols-1

Set doc=dc.getfirstdocument
Dim fieldname As String
Dim fitem As notesitem
rows=2
cols=1

Do While Not(doc Is Nothing)
For x=0 To Ubound(view.columns)
   xlapp.statusbar="正在从Notes中引入数据，请稍等......"
   If view.columns(x).IsHidden=False Then
    If view.columns(x).title<>"" Then
     fieldname = view.columns(x).itemname
     Set fitem = doc.getfirstitem(fieldname)
     xlsheet.cells(rows, cols).value = fitem.text
     cols = cols +1
    End If
   End If
Next
rows = rows+1
cols = 1
Set doc= dc.getnextdocument(doc)
Loop

%REM
xlApp.Row s("1:1").select
xlApp.Selection.Font.Bold=True
xlApp.Range(xls heet.cells(1,1),xlsheet.Cells(rows,maxcols)).Select
xlApp.Selection.Fon t.Name="Arial"
xlApp.Selection.Font.Size=9
xlApp.Selcetion.Col umns.Autofit
%END REM

With xlapp.worksheets(1)
.pagesetup.orientation = 2
.pagesetup.centerheader = "report _ confidential"
.pagesetup.rightfooter = "page &P" & Chr$(13) & "Date:&D"
.pagesetup.CenterFooter = ""
End With

xlapp.referencestyle = 1
xlapp.range("A1").Select
xlapp.statusbar = "数据导入完成。"
End Sub

b)          以表格形式导出
Sub Initialize
%REM
功能：导出内部数据到Excel中去
作者：xxx
最后修改时间：
%END REM
       On Error Goto unknowErr
       Dim session As New NotesSession
       Dim db As NotesDatabase
       Dim view As NotesView
       Dim tempdoc As NotesDocument
       Dim strTemp As String
      
       Dim strPath As String
       If session.CurrentDatabase.FilePath=session.CurrentDatabase.FileName Then
              strPath=""
       Else
              strPath=Strleftback(session.CurrentDatabase.FilePath,session.CurrentDatabase.FileName)
       End If
       Set db=New NotesDatabase("",strPath & "db_StaffInformation.nsf")
       Set view=db.GetView("hvpersonInfo")
      
       Print {Content-disposition:attachment; filename=data.xls}
       Print {<table border="1">}
       Print {<tr>}
       Print {<td>工号</td>}
       Print {<td>姓名</td>}
       Print {<td>性别</td>}
       Print {<td>单位名称</td>}
       Print {<td>职位</td>}
       Print {<td>办公地点</td>}
       Print {<td>办公电话</td>}
       Print {<td>移动电话</td>}
       Print {<td>传真</td>}
       Print {<td>IP地址</td>}
       Print {<td>邮政编码</td>}
       Print {<td>电子邮件</td>}
       Print {<td>联系地址</td>}
       Print {</tr>}
       '填写数据
       Set tempDoc=view.GetFirstDocument
       While Not tempDoc Is Nothing
              Print {<tr>}
              '工号
              Print {<td >} & Cstr(tempDoc.EmployeeID(0)) & {</td>}
              '姓名
              Dim neibuName As NotesName
              Set neibuName=New NotesName(tempDoc.myname(0))
              Print {<td >} & neibuName.Common & {</td>}
              Print {<td >} & tempDoc.Sex(0) & {</td>}
              '工作单文
              If neibuName.OrgUnit1<>"" Then
                     strTemp=neibuName.OrgUnit1
              End If
              If neibuName.OrgUnit2<>"" Then
                     strTemp=strTemp & "/" & neibuName.OrgUnit2
              End If
              If neibuName.OrgUnit3<>"" Then
                     strTemp=strTemp & "/" & neibuName.OrgUnit3
              End If
              If neibuName.OrgUnit4<>"" Then
                     strTemp=strTemp & "/" & neibuName.OrgUnit4
              End If
              Print {<td >} & strTemp & {</td>}
              '职务
              If tempDoc.JobTitle(0)="1" Then
                     strTemp="员工"
              End If
              If tempDoc.JobTitle(0)="2" Then
                     strTemp="业务主管"
              End If
              If tempDoc.JobTitle(0)="3" Then
                     strTemp="副经理"
              End If
              If tempDoc.JobTitle(0)="4" Then
                     strTemp="部门经理"
              End If
              If tempDoc.JobTitle(0)="5" Then
                     strTemp="分管领导"
              End If
              If tempDoc.JobTitle(0)="6" Then
                     strTemp="总经理"
              End If
              If tempDoc.JobTitle(0)="7" Then
                     strTemp="董事长"
              End If
              Print {<td >} & strTemp & {</td>}
              Print {<td >} & tempDoc.Location(0) & {</td>}
              Print {<td >} & tempDoc.OfficePhoneNumber(0) & {</td>}
              Print {<td >} & tempDoc.CellPhoneNumber(0) & {</td>}
              Print {<td >} & tempDoc.OfficeFAXPhoneNumber(0) & {</td>}
              Print {<td >} & tempDoc.IP(0) & {</td>}
              Print {<td >} & tempDoc.OfficeZIP(0) & {</td>}
              Print {<td >} & tempDoc.InternetAddress(0) & {</td>}
              Print {<td >} & tempDoc.OfficeStreetAddress(0) & {</td>}
              Print {</tr>}
              Set tempDoc=view.GetNextDocument(tempDoc)
       Wend
       Print {</table>}
       Exit Sub
unknowErr:
       Messagebox "错误行：" & Erl & "错误信息：" & Error
End Sub