Lotus 技术点之导出

 

a)          导出到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

 

 

c) BS环境下导出

Option Public
Use  "sysFunctionScript"
Sub Initialize
 Dim file_view As NotesView
 Dim dept_view As NotesView
 Dim dept_doc As NotesDocument
 Dim role_view As NotesView
 Dim role_doc As NotesDocument
 Dim user_view As NotesView
 Dim user_doc As NotesDocument
 Dim i As Integer
 Dim var_id As Variant
 Dim str_id As String
 Dim str_path As String
  str_path=session.GetEnvironmentString("NotesProgram",true)
' 
 On Error Goto ef
 
 REM 删除,临时生成的组织结构附件
 Set file_view=cur_db.GetView("outFile_view")
 If file_view.AllEntries.Count>0 Then
  Call file_view.AllEntries.RemoveAll(True)
 End If 
 
 i=1
 REM 导出部门
 Set dept_view=cur_db.GetView("exportDept_View")
 If dept_view.AllEntries.Count>0 Then ''存在部门
  DbPath$=str_path+"\"+Format(Cstr(Today()),"YYYY-MM-DD")+"组织结构.xls"
  fileName$=Format(Cstr(Today()),"YYYY-MM-DD")+"组织结构.xls"
  Set exapp=CreateObject("Excel.Application")  
  exapp.visible=False
  Set exwk=exapp.workbooks.add
  Set exsh=exwk.worksheets("sheet1") 
  exsh.Range("A1").Value = "部门ID"  
  exsh.Range("B1").Value = "编号"
  exsh.Range("C1").Value = "部门代码"
  exsh.Range("D1").Value = "部门名称"
  exsh.Range("E1").Value = "直接上级部门全称"
  Set dept_doc=dept_view.GetFirstDocument()
  While Not(dept_doc Is Nothing)
   i=i+1
   exsh.Range("A"+Cstr(i)).Value =  "'"+Cstr(dept_doc.DID(0))
   exsh.Range("B"+Cstr(i)).Value = Cstr(dept_doc.DOrder(0))
   exsh.Range("C"+Cstr(i)).Value = Cstr(dept_doc.unitCode(0))
   exsh.Range("D"+Cstr(i)).Value =Cstr(dept_doc.DName(0))
  ' exsh.range("D"+Cstr(i)).WrapText=True   '单元格自动
   exsh.Range("E"+Cstr(i)).Value =Cstr(dept_doc.DFName(0))
   Set dept_doc=dept_view.GetNextDocument(dept_doc)
  Wend
      REM 导出职务
  Set role_view=cur_db.GetView("role_View")
  If role_view.AllEntries.Count>0 Then ''存在职务
   Set exsh=exwk.worksheets("sheet2") 
   exsh.Range("A1").Value = "职位ID"  
   exsh.Range("B1").Value = "编号"
   exsh.Range("C1").Value = "职务代码"
   exsh.Range("D1").Value = "职务名称"
   exsh.Range("E1").Value = "所在部门"
   
   Set role_doc=role_view.GetFirstDocument()
   i=1
   While Not(role_doc Is Nothing)
    i=i+1
    exsh.Range("A"+Cstr(i)).Value =  "'"+Cstr(role_doc.RID(0))
    exsh.Range("B"+Cstr(i)).Value = Cstr(role_doc.ROrder(0))
    exsh.Range("C"+Cstr(i)).Value = Cstr(role_doc.roleCode(0))
    exsh.Range("D"+Cstr(i)).Value = Cstr(role_doc.RName(0))
    exsh.Range("E"+Cstr(i)).Value =Cstr(role_doc.RDName(0))
    Set role_doc=role_view.GetNextDocument(role_doc)
   Wend
   
   REM 导出人员   
   Set user_view=cur_db.GetView("user_View")
   If user_view.AllEntries.Count>0 Then ''存在人员
    Set exsh=exwk.worksheets("sheet3") 
    exsh.Range("A1").Value = "编号"
    exsh.Range("B1").Value = "工号"
    exsh.Range("C1").Value = "姓名"
    exsh.Range("D1").Value = "职位"
    exsh.Range("E1").Value = "默认密码（不输入默认：123456）"
    exsh.Range("F1").Value = "性别"
    exsh.Range("G1").Value = "邮件名（空值默认邮件为姓名）"
    exsh.Range("H1").Value = "别名"
    exsh.Range("I1").Value = "interNet邮箱"
    exsh.Range("J1").Value = "第一级主管"
    exsh.Range("K1").Value = "第二级主管"
    exsh.Range("L1").Value = "第三级主管"
    exsh.Range("M1").Value = "第四级主管"
    Set user_doc=user_view.GetFirstDocument()
    i=1
    While Not(user_doc Is Nothing)     
     i=i+1
     exsh.Range("A"+Cstr(i)).Value = Cstr(user_doc.UOrder(0))
     exsh.Range("B"+Cstr(i)).Value =  "'"+ Cstr(user_doc.UNumber(0))
     exsh.Range("C"+Cstr(i)).Value = Cstr(user_doc.UName(0))
     exsh.Range("D"+Cstr(i)).Value =Cstr(user_doc.URName(0))
     exsh.Range("E"+Cstr(i)).Value =Cstr("123456")
     exsh.Range("F"+Cstr(i)).Value =Cstr(user_doc.USex(0))
     exsh.Range("G"+Cstr(i)).Value =Cstr(user_doc.UMail(0))
     exsh.Range("H"+Cstr(i)).Value =  "'"+Cstr(user_doc.UBName(0))
     exsh.Range("I"+Cstr(i)).Value =Cstr(user_doc.Uimail(0))
     
     str_id=""
     If user_doc.UManagerUnid1(0)<>"" Then
      var_id=Split(user_doc.UManagerUnid1(0),",")
      For a=0 To UBound(var_id)
       If strleft(var_id(a),1)="D" Then
        str_id=str_id+","+funSystemGetDeptNameByDeptID(var_id(a))
       Else
        If StrLeft(var_id(a),1)="R" Then
         str_id=str_id+","+funSystemGetRoleNameByRoleID(var_id(a))
        Else
         str_id=str_id+","+StrRight(var_id(a),"P")
        End If
       End If
      Next
     End If
     exsh.Range("J"+Cstr(i)).Value =StrRight(str_id,",")
     str_id=""
     If user_doc.UManagerUnid2(0)<>"" Then
      var_id=Split(user_doc.UManagerUnid2(0),",")
      For a=0 To UBound(var_id)
       If StrLeft(var_id(a),1)="D" Then
        str_id=str_id+","+funSystemGetDeptNameByDeptID(var_id(a))
       Else
        If StrLeft(var_id(a),1)="R" Then
         str_id=str_id+","+funSystemGetRoleNameByRoleID(var_id(a))
        Else
         str_id=str_id+","+StrRight(var_id(a),"P")
        End If
       End If
      Next
     End If     
     exsh.Range("K"+Cstr(i)).Value =StrRight(str_id,",")
     str_id=""     
     If user_doc.UManagerUnid3(0)<>"" Then
       var_id=Split(user_doc.UManagerUnid3(0),",")
      For a=0 To UBound(var_id)
       If StrLeft(var_id(a),1)="D" Then
        str_id=str_id+","+funSystemGetDeptNameByDeptID(var_id(a))
       Else
        If StrLeft(var_id(a),1)="R" Then
         str_id=str_id+","+funSystemGetRoleNameByRoleID(var_id(a))
        Else
         str_id=str_id+","+StrRight(var_id(a),"P")
        End If
       End If
      Next
     End If 
     exsh.Range("L"+Cstr(i)).Value =StrRight(str_id,",")
     str_id=""
     If user_doc.UManagerUnid4(0)<>"" Then
      var_id=Split(user_doc.UManagerUnid4(0),",")
      For a=0 To UBound(var_id)
      ' print  var_id(a)+"--"+StrLeft(var_id(a),1)
       
       If StrLeft(var_id(a),1)="D" Then
        str_id=str_id+","+funSystemGetDeptNameByDeptID(var_id(a))
       Else
        If StrLeft(var_id(a),1)="R" Then
         str_id=str_id+","+funSystemGetRoleNameByRoleID(var_id(a))
        Else
         str_id=str_id+","+StrRight(var_id(a),"P")
        End If
       End If
      Next
     End If 
     exsh.Range("M"+Cstr(i)).Value =StrRight(str_id,",")
     
     Set user_doc=user_view.GetNextDocument(user_doc)
    Wend
   End If
  End If
  exwk.SaveAs(DbPath$)
  Dim ftpItem As NotesRichTextItem          '放到附件里
  Dim ftpOBJ As NotesEmbeddedObject
  Dim ftpDoc As NotesDocument
  Dim item As NotesItem
  Set ftpDoc=cur_db.CreateDocument
  
  keyWord$=Cstr(Now())
  ftpDoc.form="outFile_Form" ''表单名
  ftpDoc.keyWord=keyWord$ ''打开关键字
  ftpDoc.writer="*"
  Set item=ftpDoc.GetFirstItem("writer")
  item.IsAuthors=True
  Set ftpItem=New NotesRichTextItem(ftpDoc,"body")
  Set ftpOBJ=ftpItem.EmbedObject(EMBED_ATTACHMENT,"",DbPath$)
  Call ftpDoc.Save(True,False)
  exapp.quit 
  Set exapp=Nothing
  Kill DbPath$   
  filePath$="/"+Strleft(cur_db.FilePath,"\")+"/sysZZJG.nsf/outFile_view/"+ftpDoc.UniversalID+"/$FILE/"+fileName$
  
  Set file_view=Nothing
  Set dept_view=Nothing
  Set dept_doc=Nothing
  Set role_view=Nothing
  Set role_doc=Nothing
  Set user_view=Nothing
  Set user_doc=Nothing
  
  Print |<script language="javascript">|
  Print |window.location="|+filePath$+|"|
  Print |</script>|  
 End If
 
 Exit Sub
ef:
 Msgbox "【导出组织机构)|(exportUnit_Agent】"& Error$ & " at line " & Cstr(Erl)
 Exit Sub
End Sub