B/S下导出系统通讯录信息到Excel中

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 

Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=1342998