查找Outlook的文件夹 (支持通配符) , 并移动邮件至该文件夹

zhangjvhua

用Outlook 2010处理邮件归档至指定文件夹，由于文件夹的数量很多(大概200多个)，归档时要到处找文件夹，效率很低。

在网上找了两个outlook vbs 稍微修改了一下直接拿来用。

现在大部分时候可以正常使用这个功能，但不知道为什么有时会把Outlook弄假死了，只能重启Outlook。

请大家帮手看看代码是不是有什么Bug之类的问题帮手完善一下，谢谢各位！！！！！

         

================================

1. 
   
2. '查找Outlook中指定的文件夹 (支持通配符"*" / "&") , 并移动邮件至该文件夹
   
3. 
   
4. Private m_Folder As Outlook.MAPIFolder
   
5. Private m_Find As String
   
6. Private m_Wildcard As Boolean
   
7. 
   
8. Public Sub FindFolder()
   
9.         Dim Name$
   
10.         Dim Folders As Outlook.Folders
    
11.         Dim objNS As Outlook.NameSpace
    
12.         Dim MyFolder As Outlook.MAPIFolder
    
13.         Dim objItem As Outlook.MailItem
    
14.         Dim ctr As Integer
    
15. 
    
16.         Set m_Folder = Nothing
    
17.         m_Find = ""
    
18.         m_Wildcard = False
    
19. 
    
20.         Name = InputBox("Find Name:", "Search Folder", "**")
    
21.         If Len(Trim$(Name)) = 0 Then Exit Sub
    
22.         m_Find = Name
    
23. 
    
24.         m_Find = LCase$(m_Find)
    
25.         m_Find = Replace(m_Find, "%", "*")
    
26.         m_Wildcard = (InStr(m_Find, "*"))
    
27. 
    
28.         Set Folders = Application.Session.Folders
    
29.         LoopFolders Folders
    
30. 
    
31. 
    
32.         If Not m_Folder Is Nothing Then
    
33.                 If MsgBox("Activate Folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
    
34.                         On Error Resume Next
    
35.                                 ctr = 0
    
36.                         Set MyFolder = m_Folder
    
37. 
    
38.                         For Each objItem In Application.ActiveExplorer.Selection
    
39.                                 If MyFolder.DefaultItemType = olMailItem Then
    
40.                                         If objItem.Class = olMail Then
    
41.                                                 ctr = ctr + 1
    
42.                                                 objItem.Move MyFolder
    
43.                                         End If
    
44.                                 End If
    
45.                         Next
    
46.                                 Set objNS = Nothing
    
47.                                 Set MyFolder = Nothing
    
48.                 End If
    
49.         Else
    
50.                 MsgBox "Not Found", vbInformation
    
51.         End If
    
52. 
    
53. End Sub
    
54. 
    
55. '查找文件夹
    
56. Private Sub LoopFolders(Folders As Outlook.Folders)
    
57.   Dim F As Outlook.MAPIFolder
    
58.   Dim Found As Boolean
    
59. 
    
60.   For Each F In Folders
    
61.   
    
62.     If m_Wildcard Then
    
63.                 Found = (LCase$(F.Name) Like m_Find)
    
64.         Else
    
65.                 Found = (LCase$(F.Name) = m_Find)
    
66.     End If
    
67. 
    
68.     If Found Then
    
69.       Set m_Folder = F
    
70.       Exit For
    
71.     Else
    
72.       LoopFolders F.Folders
    
73.       If Not m_Folder Is Nothing Then Exit For
    
74.     End If
    
75.        
    
76.   Next
    
77.   
    
78. End Sub
    

复制代码

zhangjvhua

  已验证以上VBS没问题， 假死是因为Lookeen引起的。