Question

我需要帮助来加快在http://www.vboffice.net/en/developers/find-folder-by-name/上找到的Outlook宏的运行速度，并且可以正常工作，但是找到文件夹时需要45秒到1分钟的响应时间，而找不到文件夹则需要13分钟。我认为这与以下事实有关：我喜欢4-5个邮箱，每个邮箱都有几个子文件夹，并且每个邮箱都花大量时间循环浏览。有什么办法可以加快速度吗？我一直在寻找，但找不到答案，我找到的每个解决方案都适用于Excel，但不适用于Outlook。
这是代码：

    Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean

Private Const SpeedUp As Boolean = False
Private Const StopAtFirstMatch As Boolean = False

Public Sub FindFolder()
  Dim Name$
  Dim Folders As Outlook.Folders

  Set m_Folder = Nothing
  m_Find = ""
  m_Wildcard = False

  Name = InputBox("Find name:", "Search folder")
  If Len(Trim$(Name)) = 0 Then Exit Sub
  m_Find = Name

  m_Find = LCase$(m_Find)
  m_Find = Replace(m_Find, "%", "*")
  m_Wildcard = (InStr(m_Find, "*"))

  Set Folders = Application.Session.Folders
  LoopFolders Folders

  If Not m_Folder Is Nothing Then
    If MsgBox("Activate folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
      Set Application.ActiveExplorer.CurrentFolder = m_Folder
    End If
  Else
    MsgBox "Not found", vbInformation
  End If
End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
  Dim F As Outlook.MAPIFolder
  Dim Found As Boolean

  If SpeedUp = False Then DoEvents

  For Each F In Folders
    If m_Wildcard Then
      Found = (LCase$(F.Name) Like m_Find)
    Else
      Found = (LCase$(F.Name) = m_Find)
    End If

    If Found Then
      If StopAtFirstMatch = False Then
        If MsgBox("Found: " & vbCrLf & F.FolderPath & vbCRLF & vbCrLf & "Continue?", vbQuestion Or vbYesNo) = vbYes Then
          Found = False
        End If
      End If
    End If
    If Found Then
      Set m_Folder = F
      Exit For
    Else
      LoopFolders F.Folders
      If Not m_Folder Is Nothing Then Exit For
    End If
  Next
End Sub

谢谢！

Answer 1

通常的建议是不要循环浏览文件夹中的所有子文件夹（或项目）。不幸的是，OOM中的Folders集合未实现与Find集合所实现的方法类似的FindNext / Restrict和Items方法。

在扩展MAPI（C ++或Delphi）中，您可以递归地限制文件夹层次结构表，以仅返回（1）符合搜索标准或（2）具有子文件夹的文件夹。对于带有子文件夹的文件夹，您可以通过输入id来打开它们并对其进行递归处理。

如果可以选择使用Redemption，则可以尝试以下脚本，它应该比当前的实现快得多。

query = "list"
Dim foundFolder

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
'set Folder = Session.GetFolderFromID(Application.ActiveExplorer.CurrentFolder.EntryID)
for each store in Session.Stores
  set Folder = store.IPMRootFolder
  set match = ProcessFolders(Folder.Folders)
  if match Is Nothing Then
    Debug.Print "No matches found in " & store.Name
  Else
    MsgBox "Found folder: '" & match.Name & "' in " & store.Name
    Exit for
  End If
next

function ProcessFolders(flds)
  set ProcessFolders = Nothing

  set rs = flds.MAPITable.ExecSQL("SELECT Name, EntryID, ""http://schemas.microsoft.com/mapi/proptag/0x360A000B"" AS PR_SUBFOLDERS" & _
                                            " from folders WHERE Name like '%" & query & "%' or PR_SUBFOLDERS = 'true'")
  'check for matches on this level
  while not rs.EOF

    Debug.Print(rs.Fields("Name").Value & ": " & rs.Fields("PR_SUBFOLDERS").Value)
    if InStr(rs.Fields("Name"), query) Then
      Debug.Print "match found: " & rs.Fields("Name")
      set ProcessFolders = flds.Session.GetFolderFromID(rs.Fields("EntryID"))
      Exit Function
    End If
    rs.MoveNext
  wend
  'process subfolders
  if rs.RecordCount > 0 Then
    rs.MoveFirst
    while not rs.EOF
      if rs.Fields("PR_SUBFOLDERS").Value Then
        set subfolder = flds.Session.GetFolderFromID(rs.Fields("EntryID"))
        set ProcessFolders = ProcessFolders(subFolder.Folders)
        if Not (ProcessFolders Is Nothing) Then Exit Function
      End If
      rs.MoveNext
    wend
  End If
end function

加速Outlook宏

1 个答案: