Чтобы изменить макрос для перемещения электронной почты в зависимости от домена отправителя - PullRequest
Новая
       8

Чтобы изменить макрос для перемещения электронной почты в зависимости от домена отправителя

0 голосов
/ 09 июля 2019

Прикрепленный скрипт к выбранным электронным письмам создает папку на PST не по умолчанию (OutlookEmail.PST) на основе имени отправителя и перемещает электронное письмо в папку. Например, для MyTest@thisdomain.com создается папка MyTest . Мне нужно посоветовать изменить скрипт, чтобы он создавал папку на основе домена отправителя, например, для thisdomain.com с подпапкой MyTest , а затем перемещал электронную почту.

Этот макрос из https://www.slipstick.com/developer/file-messages-senders-name/

Public Sub MoveSelectedMessages()
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objSourceFolder As Outlook.Folder
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim obj As Object

    Dim objVariant As Variant
    Dim lngMovedItems As Long
    Dim intCount As Integer
    Dim intDateDiff As Integer
    Dim strDestFolder As String


    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set currentExplorer = objOutlook.ActiveExplorer
    Set Selection = currentExplorer.Selection
    Set objSourceFolder = currentExplorer.CurrentFolder

    For Each obj In Selection
        Set objVariant = obj

    If objVariant.Class = olMail Then
       intDateDiff = DateDiff("d", objVariant.SentOn, Now)
         ' I'm using 40 days, adjust as needed.
       If intDateDiff >= 0 Then
         sSenderName = objVariant.SentOnBehalfOfName
       If sSenderName = ";" Then
         sSenderName = objVariant.senderName
      End If

On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
'Dim objInbox  As Outlook.MAPIFolder
'Set objInbox = objNamespace.Folders(objDestFolder).Folders("OutlookEmail")  ' or whereever the folder is
'Set objDestFolder = objInbox.Folders(sSenderName)


Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders(sSenderName)
'Set objDestFolder = objDestFolder.Folders(sSenderName)


If objDestFolder Is Nothing Then
    Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders.Add(sSenderName)
       End If
            objVariant.Move objDestFolder
            'count the # of items moved
            lngMovedItems = lngMovedItems + 1
            Set objDestFolder = Nothing
        End If
    End If
        Err.Clear
    Next

' Display the number of items that were moved.
' MsgBox "Moved " & lngMovedItems & " messages(s)."

    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set objOutlook = Nothing
    Set objNamespace = Nothing
    Set objSourceFolder = Nothing
End Sub

Модификация, которая создает домен, но не подпапку: 

If intDateDiff >= 0 Then
  sSenderName = Right(objVariant.SenderEmailAddress, Len(objVariant.SenderEmailAddress) - InStr(objVariant.SenderEmailAddress, "@"))
...