Sub Click(Source As Button)

%REM

导出所有的部门到excel，为了修改后的回写修改

%END REM

Dim session As New NotesSession

Dim cur_db As NotesDatabase

Dim view As NotesView

Dim workspace As New NotesUIWorkspace

Dim cur_doc As NotesDocument

Set cur_db=session.CurrentDatabase

Set view=cur_db.GetView("renyByBum")

 

On Error Goto errorhandle               'excel 进程控制

Dim var_exapp As Variant   'Excel对象

Dim var_exwk  As Variant   'Excel对象 

Dim var_xlsheet As Variant 'Excel对象

Set var_exapp=CreateObject("Excel.Application")

var_exapp.visible=False

var_exapp.DisplayAlerts=False

Set var_exwk=var_exapp.workbooks.add

Set var_xlsheet=var_exwk.worksheets("sheet1")

fileName1$="人员列表"          'EXCEL 名称

DbPath1$=session.GetEnvironmentString("Directory",True)

DbPath$=DbPath1$+"\"+fileName1$+".xls"

fileName$ = Dir$(DbPath$, 0)

If Trim(fileName$)<>"" Then

DbPath$=DbPath1$+"\"+fileName$

End If

'''''''''''''''表头'''''''''''''''''

var_xlsheet.Cells(1,1).Value ="编号"

var_xlsheet.Cells(1,1).ColumnWidth="10"

var_xlsheet.Cells(1,2).Value ="姓名"

var_xlsheet.Cells(1,2).ColumnWidth="10"

var_xlsheet.Cells(1,3).Value ="性别"

var_xlsheet.Cells(1,3).ColumnWidth="10"

 

var_xlsheet.Cells(1,4).Value ="职务"

var_xlsheet.Cells(1,4).ColumnWidth="10"

var_xlsheet.Cells(1,5).Value ="职称"

var_xlsheet.Cells(1,5).ColumnWidth="10"

var_xlsheet.Cells(1,6).Value ="上岗证"

var_xlsheet.Cells(1,6).ColumnWidth="10"

var_xlsheet.Cells(1,7).Value ="所在部门和角色"

var_xlsheet.Cells(1,7).ColumnWidth="35"

var_xlsheet.Cells(1,8).Value ="文档标识ID"

var_xlsheet.Cells(1,8).ColumnWidth="32"

 

Print "正在导出人员列表到excel....."

Set cur_doc=view.GetFirstDocument

m=2

While Not cur_doc Is Nothing 

var_xlsheet.Cells(m,1).Value=Cstr(cur_doc.bianh(0))              '编号

var_xlsheet.Cells(m,2).Value=Cstr(cur_doc.xingm(0))              '姓名

var_xlsheet.Cells(m,3).Value=Cstr(cur_doc.xingb(0))              '性别

var_xlsheet.Cells(m,4).Value=Cstr(cur_doc.zhiw(0))              '职务

var_xlsheet.Cells(m,5).Value=Cstr(cur_doc.chic(0))              '职称

If Cstr(cur_doc.shanggz(0))="1"Then

var_xlsheet.Cells(m,6).Value="有"         '上岗证

Else

var_xlsheet.Cells(m,6).Value="无"         '上岗证

End If

var_xlsheet.Cells(m,7).Value=Cstr(cur_doc.unitAndRole(0))           '所属部门角色

var_xlsheet.Cells(m,8).Value=Cstr(cur_doc.UniversalID)           '文档标识ID

m=m+1

Set cur_doc=view.GetNextDocument(cur_doc)

Wend

 

 

'''''''''''''''''''处理进程和保存文档''''''''''

'Msgbox DbPath$

var_exwk.SaveAs(DbPath$)

var_exwk.Save

var_exapp.quit

'''''''''''''''''''''''''''''''''''''''''''''''

Print "导出成功，文件存放在："+DbPath$

Exit Sub

errorhandle:

cur_doc.S_State="4"                         'Excel对象出错

Call cur_doc.Save(True,False)

var_exapp.quit

Set var_exapp=Nothing

Kill DbPath$

 

End Sub