Sub Initialize
'/*******************************************
'功 能: B/S下导出系统通讯录信息到Excel中
'注意事项: 1、Domino服务器上必须安装Excel
' 2、代理安全性等级设置为3
'*******************************************/
On Error Goto errHandle
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Set db=ss.GetDatabase("","names.nsf")
Set view=db.GetView("People")
If view Is Nothing Then
Msgbox "视图People不存在!"
Exit Sub
End If
If view.AllEntries.Count<1 Then
Msgbox "视图中没有数据可导出!"
Exit Sub
End If
'///启动Excel
Dim ExcelApp As Variant
Dim WorkBooks As Variant
Dim WorkBook As Variant
Dim sheet As Variant
Set ExcelApp=CreateObject("Excel.Application")
If ExcelApp Is Nothing Then
Msgbox "无法启动Microsfot Excel,请检查你的服务器是否已经安装!",0+64,"提示信息"
Exit Sub
End If
ExcelApp.Visible=False '是否为不可见
Set WorkBooks=ExcelApp.Workbooks.Add
WorkBooks.Activate
Set WorkBook=ExcelApp.ActiveWorkbook
If WorkBook Is Nothing Then
Msgbox "无法启动Excel,请检查是否安装。"
Exit Sub
End If
Set sheet=WorkBook.Sheets(1)
'************************************
REM 输出开始
'设置行高
sheet.Rows.RowHeight=20
'垂直居中
sheet.Rows.VerticalAlignment =2
sheet.Range("1:1").Font.Size=18
sheet.Range("1:1").Borders.Weight=1
sheet.Rows(1).RowHeight=60
sheet.Range("A1:E1").Merge(True) '合并单元格
sheet.Range("A1:E1").MergeCells=True '合并单元格
sheet.Cells(1,1)="系统通讯录"
sheet.Cells(1,1).HorizontalAlignment=3
sheet.Cells(1,1).VerticalAlignment=2
'增加标题行
sheet.Range("2:2").Font.Size=12
sheet.Range("2:2").Borders.Weight=2
sheet.Rows(2).RowHeight=25
sheet.Cells(2, 1) = "序号" '序号
sheet.Cells(2,1).HorizontalAlignment=3
Sheet.Cells(2,1).VerticalAlignment=2
sheet.Columns(1).ColumnWidth=8
sheet.Cells(2, 2) = "姓名"
sheet.Columns(2).ColumnWidth=10
sheet.Cells(2, 3) = "系统用户"
sheet.Columns(3).ColumnWidth=40
sheet.Cells(2, 4) = "手机"
sheet.Columns(4).ColumnWidth=15
sheet.Cells(2, 5) = "电子邮件"
sheet.Columns(5).ColumnWidth=35
Dim varName As Variant
Dim lngCount As Long
lngCount=2
'写入文档内容
Set doc=view.GetFirstDocument
'遍历选中的文档,把信息写入Excel表中
While Not(doc Is Nothing)
With doc
lngCount=lngCount+1
sheet.Cells(lngCount, 1) =Cstr(lngCount - 2) '序号
sheet.Cells(lngCount,1).HorizontalAlignment=3
varName=Evaluate( {@Name([Abbreviate];FullName)},doc)
sheet.Cells(lngCount, 2) = Strleft(varName(0),"/")
sheet.Cells(lngCount, 3) = varName(0)
sheet.Cells(lngCount, 4) = .CellPhoneNumber(0)
sheet.Cells(lngCount, 5) = .InternetAddress(0)
End With
Set doc=View.GetNextDocument(doc)
Wend
sheet.UsedRange.Select
sheet.UsedRange.WrapText=True
sheet.UsedRange.Borders.Weight=2
Dim strPath As String
strPath = ss.GetEnvironmentString("DIRECTORY",True)
strPath = strPath & "/domino/html/" & Format(Now,"yyyymmddhhnnss") & ".xls"
Call WorkBook.SaveAs(strPath)
Call ExcelApp.Quit
Set ExcelApp = Nothing
'通过浏览器打开Excel文档
Print {<script language="javascript">}
Print {location.href="/} _fcksavedurl=""/}" & Format(Now,"yyyymmddhhnnss") & {.xls";}
Print {</script>}
Exit Sub
errHandle:
Msgbox "ExportView Erl:" & Erl
End Sub
'/*******************************************
'功 能: B/S下导出系统通讯录信息到Excel中
'注意事项: 1、Domino服务器上必须安装Excel
' 2、代理安全性等级设置为3
'*******************************************/
On Error Goto errHandle
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Set db=ss.GetDatabase("","names.nsf")
Set view=db.GetView("People")
If view Is Nothing Then
Msgbox "视图People不存在!"
Exit Sub
End If
If view.AllEntries.Count<1 Then
Msgbox "视图中没有数据可导出!"
Exit Sub
End If
'///启动Excel
Dim ExcelApp As Variant
Dim WorkBooks As Variant
Dim WorkBook As Variant
Dim sheet As Variant
Set ExcelApp=CreateObject("Excel.Application")
If ExcelApp Is Nothing Then
Msgbox "无法启动Microsfot Excel,请检查你的服务器是否已经安装!",0+64,"提示信息"
Exit Sub
End If
ExcelApp.Visible=False '是否为不可见
Set WorkBooks=ExcelApp.Workbooks.Add
WorkBooks.Activate
Set WorkBook=ExcelApp.ActiveWorkbook
If WorkBook Is Nothing Then
Msgbox "无法启动Excel,请检查是否安装。"
Exit Sub
End If
Set sheet=WorkBook.Sheets(1)
'************************************
REM 输出开始
'设置行高
sheet.Rows.RowHeight=20
'垂直居中
sheet.Rows.VerticalAlignment =2
sheet.Range("1:1").Font.Size=18
sheet.Range("1:1").Borders.Weight=1
sheet.Rows(1).RowHeight=60
sheet.Range("A1:E1").Merge(True) '合并单元格
sheet.Range("A1:E1").MergeCells=True '合并单元格
sheet.Cells(1,1)="系统通讯录"
sheet.Cells(1,1).HorizontalAlignment=3
sheet.Cells(1,1).VerticalAlignment=2
'增加标题行
sheet.Range("2:2").Font.Size=12
sheet.Range("2:2").Borders.Weight=2
sheet.Rows(2).RowHeight=25
sheet.Cells(2, 1) = "序号" '序号
sheet.Cells(2,1).HorizontalAlignment=3
Sheet.Cells(2,1).VerticalAlignment=2
sheet.Columns(1).ColumnWidth=8
sheet.Cells(2, 2) = "姓名"
sheet.Columns(2).ColumnWidth=10
sheet.Cells(2, 3) = "系统用户"
sheet.Columns(3).ColumnWidth=40
sheet.Cells(2, 4) = "手机"
sheet.Columns(4).ColumnWidth=15
sheet.Cells(2, 5) = "电子邮件"
sheet.Columns(5).ColumnWidth=35
Dim varName As Variant
Dim lngCount As Long
lngCount=2
'写入文档内容
Set doc=view.GetFirstDocument
'遍历选中的文档,把信息写入Excel表中
While Not(doc Is Nothing)
With doc
lngCount=lngCount+1
sheet.Cells(lngCount, 1) =Cstr(lngCount - 2) '序号
sheet.Cells(lngCount,1).HorizontalAlignment=3
varName=Evaluate( {@Name([Abbreviate];FullName)},doc)
sheet.Cells(lngCount, 2) = Strleft(varName(0),"/")
sheet.Cells(lngCount, 3) = varName(0)
sheet.Cells(lngCount, 4) = .CellPhoneNumber(0)
sheet.Cells(lngCount, 5) = .InternetAddress(0)
End With
Set doc=View.GetNextDocument(doc)
Wend
sheet.UsedRange.Select
sheet.UsedRange.WrapText=True
sheet.UsedRange.Borders.Weight=2
Dim strPath As String
strPath = ss.GetEnvironmentString("DIRECTORY",True)
strPath = strPath & "/domino/html/" & Format(Now,"yyyymmddhhnnss") & ".xls"
Call WorkBook.SaveAs(strPath)
Call ExcelApp.Quit
Set ExcelApp = Nothing
'通过浏览器打开Excel文档
Print {<script language="javascript">}
Print {location.href="/} _fcksavedurl=""/}" & Format(Now,"yyyymmddhhnnss") & {.xls";}
Print {</script>}
Exit Sub
errHandle:
Msgbox "ExportView Erl:" & Erl
End Sub