根据对话框列表所选地市拆分邮件库的代码

环境：安徽移动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 Sub
errproc:
 Msgbox Error$ + " in line:" + Cstr(Erl()) + " in Agent chaifenmail"
 Msgbox "已处理了" + Cstr(i) + "个邮件库！当前处理的邮件库的名称为：" + db.FileName
 'Resume Next
End Sub