环境：安徽移动OA系统Mail服务器
作用：因为所有地市人员的邮件库在同一个目录下，过于混杂，所以有必要根据所选将一部分地市的邮件库拆分出来重新放在另一个目录下面
Sub Initialize On Error Goto errproc Dim session As New notessession Dim db As notesdatabase Dim archiveDb As NotesDatabase Dim namedb As notesdatabase Dim nameview As notesview Dim namedoc As notesdocument Dim maildoc As notesdocument Dim doc As NotesDocument Dim item As notesitem Dim regionnames As String Dim collection As notesdocumentcollection Dim nam As notesname Dim i As Integer Dim ret As Variant Dim retK() As Integer Set db=session.currentdatabase Set doc=session.DocumentContext Set item=doc.getfirstitem("Region") regionnames=item.text ret=Split(regionnames,";") Redim retK(Ubound(ret)+1) For k=0 To Ubound(retK) retK(k)=0 Next If doc.RouteToPut(0)="" Then Msgbox("您还没有填写要存放拆分邮件库的目录！") Exit Sub End If Set dbdir=session.GetDbDirectory("dev3/devoa") Set db = dbdir.GetFirstDatabase(DATABASE) Set namedb=session.GetDatabase("dev3/devoa","names") Set nameview=namedb.GetView("People") i=0 While Not (db Is Nothing) filepath$=db.FilePath If Instrb(1,filepath$,"mail/")>0 Then If Not db.isOpen Then Call db.Open("","") End If Set namedoc=nameview.GetDocumentByKey(db.Title) If Not namedoc Is Nothing Then Set nam=New notesname(namedoc.FullName(0)) GS$=Strleft(Strright(nam.Canonical,"OU="),"/") For k=0 To Ubound(ret) If GS$=ret(k) Then retK(k)=1 End If Next If Instr(regionnames,GS$)<>0 Then Set archiveDb = db.CreateFromTemplate( "dev3/devoa", doc.RouteToPut(0)+ "/" +db.Filename,True) i=i+1 End If End If End If Set db = dbdir.GetNextDatabase Wend NotHave$="" For k=0 To Ubound(retK)-1 If retK(k)=0 Then NotHave$=NotHave$ + "、" + ret(k) End If Next If NotHave$<>"" Then Msgbox("您所选择的地市：" + Strright(NotHave$,"、") + "的邮件库在此服务器上找不到！") End If Exit Suberrproc: Msgbox Error$ + " in line:" + Cstr(Erl()) + " in Agent chaifenmail" Msgbox "已处理了" + Cstr(i) + "个邮件库！当前处理的邮件库的名称为：" + db.FileName 'Resume NextEnd Sub
