On Error Goto errhandle
Set F = New f_default
Msgbox "开始。。。。"
Dim ws As New NotesUIWorkspace
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim files As Variant
Dim schar As String
Dim doc As NotesDocument
Dim excelapplication
Dim i,sheet
Set db = ss.CurrentDatabase
files = ws.openfiledialog(False,"请选择要导入的Excel文件","Excel file/*.xls")
sheeet = 1
If Not(Isempty(files)) Then '如果用户选择了文件,或者输入了文件名,那么就开始准备打开excel文件。
Set excelapplication = createobject("excel.application")
Set excelworkbook = excelapplication.workbooks.open(files)
If excelworkbook Is Nothing Then '如果未找到文件,则退出
excelapplication.quit
Exit Sub
End If
Set excelsheet = excelworkbook.worksheets(1)
i = 2 '从第二行开始读取'一个sheet里面所有记录循环
Do Until Cstr(excelsheet.cells(i,1).value) =""
Set doc = New NotesDocument(db)
doc.Form = "f_XCPKFLX" '表单名
doc.MingCheng = "" + excelsheet.cells(i,1).value + ""
'doc.jiaohuodanhao = excelsheet.cells(i,2).value '交货单号
'doc.yifuyunfei = excelsheet.cells(i,3).value '已付运费
'doc.kaifeisuozaidi = excelsheet.cells(i,4).value '开票所在地
doc.SYS_SUBMITDATE = Cstr(Now())
doc.Creater = "CN=admin/O=org"
doc.Admin_SYS = "HR管理员"
Dim item As NotesItem
Set item = doc.GetFirstItem("Admin_SYS")
item.AppendToTextList("CN=admin/O=org")
item.AppendToTextList("工作门户系统管理员群组")
item.AppendToTextList("工作门户系统管理员群组")
item.AppendToTextList("系统管理员")
Call F.SetItemProperty(doc,"Admin_SYS","R")'设置权限
doc.AllEditors = "*"
Call F.SetItemProperty(doc,"AllEditors","R")
doc.Replicate_SYS = "LocalDomainServers"
Call F.SetItemProperty(doc,"Replicate_SYS","R")
doc.SYSTEM="*"
Call F.SetItemProperty(doc,"SYSTEM","R") 'Read
doc.SYS_SYSTEM="*"
Call F.SetItemProperty(doc,"SYS_SYSTEM","R")
Call doc.save(True,False) '保存
i=i+1
Loop
excelworkbook.close(False)
excelapplication.quit
Set excelapplication = Nothing
End If
Msgbox "完成!"
Exit Sub
errhandle:
Call F.printerrmsg(doc,"Initialize")
Exit Sub
End Sub