在outlook复制所有文件夹

公司里用outlook来做邮件客户段, 有些同事的邮件分类的很多; 客户, 上司, 小组,  

极端的可能超过几百上千个, 

所以在这里做了个脚本, 自动复制文件夹架构到一个新的目录里..

(其实这个功能可以封存->过滤来做到, )

记得第一次弄时手动帮一个同事复制过.. 100多个也够烦人的..

 

代码如下:

' 複製outlook 根目錄下的所有目錄,包括嵌套的' William [2010/07/29]Dim sCloneFolderName As StringSub cloneAllFolders() Dim olApp As New Outlook.Application Dim oRoot As Outlook.Folder ' 設置新建的根目錄名字 sCloneFolderName = "ZZZ_CLONE_FOLDER" ' 獲取收件箱 Set oRoot = olApp.Session.GetDefaultFolder(olFolderInbox) ' 創建一個臨時的根目錄 oRoot.folders.Add sCloneFolderName createFolder oRoot, oRoot.folders(sCloneFolderName)End SubPrivate Sub createFolder(ByVal oFolder As Outlook.Folder, ByVal oNewFolder As Outlook.Folder) Dim folders As Outlook.folders Dim Folder As Outlook.Folder Dim tmpFolder As Outlook.Folder Dim foldercount As Integer On Error Resume Next Set folders = oFolder.folders ' 子文件夾數量, ' 因為不需要算剛新建的文件夾, 所以總數減 1 foldercount = folders.Count ' 判斷是否有子文件夾 If foldercount > 0 Then For Each Folder In folders ' 判斷是否為根目錄, 否則會把新建的根目錄也算進去 If Trim(Folder.Name) <> sCloneFolderName Then ' 新增子文件夾 oNewFolder.folders.Add Folder.Name ' 嵌套循環查找子文件夾 createFolder Folder, oNewFolder.folders(Folder.Name) End If Next End If End Sub