ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 3967|回复: 1

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-7-3 13:11 | 显示全部楼层 |阅读模式


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

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

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

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

          Outlook_VBA.png


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


  1. '查找Outlook中指定的文件夹 (支持通配符"*" / "&") , 并移动邮件至该文件夹

  2. Private m_Folder As Outlook.MAPIFolder
  3. Private m_Find As String
  4. Private m_Wildcard As Boolean

  5. Public Sub FindFolder()
  6.         Dim Name$
  7.         Dim Folders As Outlook.Folders
  8.         Dim objNS As Outlook.NameSpace
  9.         Dim MyFolder As Outlook.MAPIFolder
  10.         Dim objItem As Outlook.MailItem
  11.         Dim ctr As Integer

  12.         Set m_Folder = Nothing
  13.         m_Find = ""
  14.         m_Wildcard = False

  15.         Name = InputBox("Find Name:", "Search Folder", "**")
  16.         If Len(Trim$(Name)) = 0 Then Exit Sub
  17.         m_Find = Name

  18.         m_Find = LCase$(m_Find)
  19.         m_Find = Replace(m_Find, "%", "*")
  20.         m_Wildcard = (InStr(m_Find, "*"))

  21.         Set Folders = Application.Session.Folders
  22.         LoopFolders Folders


  23.         If Not m_Folder Is Nothing Then
  24.                 If MsgBox("Activate Folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
  25.                         On Error Resume Next
  26.                                 ctr = 0
  27.                         Set MyFolder = m_Folder

  28.                         For Each objItem In Application.ActiveExplorer.Selection
  29.                                 If MyFolder.DefaultItemType = olMailItem Then
  30.                                         If objItem.Class = olMail Then
  31.                                                 ctr = ctr + 1
  32.                                                 objItem.Move MyFolder
  33.                                         End If
  34.                                 End If
  35.                         Next
  36.                                 Set objNS = Nothing
  37.                                 Set MyFolder = Nothing
  38.                 End If
  39.         Else
  40.                 MsgBox "Not Found", vbInformation
  41.         End If

  42. End Sub

  43. '查找文件夹
  44. Private Sub LoopFolders(Folders As Outlook.Folders)
  45.   Dim F As Outlook.MAPIFolder
  46.   Dim Found As Boolean

  47.   For Each F In Folders
  48.   
  49.     If m_Wildcard Then
  50.                 Found = (LCase$(F.Name) Like m_Find)
  51.         Else
  52.                 Found = (LCase$(F.Name) = m_Find)
  53.     End If

  54.     If Found Then
  55.       Set m_Folder = F
  56.       Exit For
  57.     Else
  58.       LoopFolders F.Folders
  59.       If Not m_Folder Is Nothing Then Exit For
  60.     End If
  61.        
  62.   Next
  63.   
  64. End Sub
复制代码


评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-7-5 15:32 | 显示全部楼层
  已验证以上VBS没问题, 假死是因为Lookeen引起的。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 15:07 , Processed in 0.045623 second(s), 14 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表