vba - 如果需要，根据主题行中的文本创建 Outlook 规则以创建文件夹

Question

关闭。这个问题需要更多focused .它目前不接受答案。












想改善这个问题吗？更新问题，使其仅关注一个问题 editing this post .

2年前关闭。




Improve this question




我正在寻找一种清晰的方法来使用 vba 在收到电子邮件时读取主题行，以便创建新文件夹或仅使用现有文件夹将电子邮件移入。我看过一些 vba 示例，但没有一个解决在带有 Outlook 的 vba 编辑器中找到的新邮件方法。

Answer 1

我只是为此编写了代码。我的宏在电子邮件中搜索特定字符串，然后获取之后的所有内容并使用该名称创建一个文件夹。你需要一些函数来:
1) 检查文件夹是否已经存在
2)如果没有就创建它
3) 将 MailItem 移动到新文件夹
4)调用那些函数

注意:其中大部分是硬编码的，如果需要，可以更改为接受用户输入。此外，它不适用于子文件夹(您必须对其进行自定义)。

1)检查文件夹:

Function CheckForFolder(strFolder As String) As Boolean

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder
    Dim FolderToCheck As Outlook.MAPIFolder


    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

    On Error Resume Next
    Set FolderToCheck = olInbox.Folders(strFolder)
    On Error GoTo 0

    If Not FolderToCheck Is Nothing Then
        CheckForFolder = True
    End If

ExitProc:
    Set FolderToCheck = Nothing
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function

2)创建:

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

    Set CreateSubFolder = olInbox.Folders.Add(strFolder)

    ExitProc:
    Set olInbox = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Function

3)搜索和移动:

Function SearchAndMove(lookFor As String)

 Dim olApp As Outlook.Application
 Dim olNS As Outlook.NameSpace
 Dim olInbox As Outlook.MAPIFolder
 Dim FolderToCheck As Outlook.MAPIFolder
 Dim myItem As Object
 Dim MyFolder As Outlook.MAPIFolder
 Dim lookIn As String
 Dim newName As String
 Dim location As Integer


 Set olApp = Outlook.Application
 Set olNS = olApp.GetNamespace("MAPI")
 Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
     For Each myItem In olInbox.Items
     lookIn = myItem.Subject
     If InStr(lookIn, lookFor) Then
         location = InStr(lookIn, lookFor)
                 newName = Mid(lookIn, location)
            If CheckForFolder(newName) = False Then
                Set MyFolder = CreateSubFolder(newName)
                myItem.Move MyFolder
                    Else
                Set MyFolder = olInbox.Folders(newName)
                myItem.Move MyFolder
            End If
        End If
    Next myItem
End Function

4)调用函数:

Sub myMacro()
    Dim str as String
    str = "Thing to look for in the subjectline"
    SearchAndMove (str)

End Sub