Правило подать почту в существующей или недавно созданной папке

Я плохо знаком с VBA и нуждаюсь в вашей помощи на правиле, которое будет искать предмет электронной почты и если определенная последовательность "LSC _" найденный в предмете, например: LSC_IND_TATA и соглашение о присвоении имен по умолчанию - LSC_XXX_XXX или [LSC_XXX_XXX] тогда, сообщение перемещено в ту названную подпапку или недавно созданную подпапку LSC.

Таким образом, структура папки Outlook похожа ниже

LSC

- LSC_IND_TATA

- LSC_IND_TATA_02

- LSC_xxx_xxx

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

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

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

Sub myMacro()
Dim str As String
str = "LSC_"
SearchAndMove (str)
End Sub
2
добавлено отредактировано
Просмотры: 3
источник
nl ja de

1 ответы

Function CheckForFolder(strFolder As String) As Boolean

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

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Dim FolderToCheck As Outlook.MAPIFolder

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

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

On Error Resume Next
Set FolderToCheck = olInbox_Target.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

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

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

Dim olInbox_Target As Outlook.MAPIFolder ' <---

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

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

Set CreateSubFolder = olInbox_Target.Folders.Add(strFolder)

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

Function SearchAndMove(lookFor As String, myitem As mailItem)

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
'Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target 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)
Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

'For Each myItem In olInbox.Items

    lookIn = myitem.Subject

    If InStr(lookIn, lookFor) Then

        location = InStr(lookIn, lookFor)
        newName = Mid(lookIn, location)

        If Right(newName, 1) = "]" Then
            newName = Left(newName, Len(newName) - 1)
        End If

        If CheckForFolder(newName) = False Then
            Set MyFolder = CreateSubFolder(newName)
            myitem.Move MyFolder
        Else
            Set MyFolder = olInbox_Target.Folders(newName)
            myitem.Move MyFolder
        End If

    End If

'Next myItem

End Function

' Choose this in Run a Script
Sub myMacro(itm As mailItem)
Dim str As String
str = "LSC_"
SearchAndMove str, itm
End Sub

' To test
' Manually select an email with an appropriate subject
Sub myMacroTest()
Dim itm As mailItem
Set itm = ActiveExplorer.Selection(1)
myMacro itm
End Sub
0
добавлено
источник