数据导出(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 {}
}
Exit Sub
unknowErr:
Messagebox "错误行：" & Erl & "错误信息：" & Error
End Sub
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 {
| 工号 | }姓名 | }性别 | }单位名称 | }职位 | }办公地点 | }办公电话 | }移动电话 | }传真 | }IP地址 | }邮政编码 | }电子邮件 | }联系地址 | }
| } & Cstr(tempDoc.EmployeeID(0)) & { | }} & neibuName.Common & { | }} & tempDoc.Sex(0) & { | }} & strTemp & { | }} & strTemp & { | }} & tempDoc.Location(0) & { | }} & tempDoc.OfficePhoneNumber(0) & { | }} & tempDoc.CellPhoneNumber(0) & { | }} & tempDoc.OfficeFAXPhoneNumber(0) & { | }} & tempDoc.IP(0) & { | }} & tempDoc.OfficeZIP(0) & { | }} & tempDoc.InternetAddress(0) & { | }} & tempDoc.OfficeStreetAddress(0) & { | }
Exit Sub
unknowErr:
Messagebox "错误行：" & Erl & "错误信息：" & Error
End Sub