Путь к папке в корпоративном хранилище с использованием VBA для переноса электронной почты - PullRequest
Новая
       15

Путь к папке в корпоративном хранилище с использованием VBA для переноса электронной почты

0 голосов
/ 17 сентября 2018

У меня есть длинный список папок и множество правил для Outlook, которые можно обрабатывать с помощью стандартного менеджера правил. Я написал код, который будет классифицировать и перемещать элементы в папки, но недавно я был перенесен в Enterprise Vault. Я пытаюсь найти путь к папке, чтобы обновить мой код. Я пробовал что-то вроде

Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")

но, честно говоря, я понятия не имею, каким должен быть правильный путь. Все, что я нахожу в Интернете, касается вытаскивания выбранных предметов из хранилища, а не перемещения предметов в него. Ниже приводится выдержка из существующего кода. Это на Office 365 / Outlook 2016. 

Sub Sort_Test(Item)
    Dim Msg As Object
    Dim Appt As Object
    Dim Meet As Object
    Dim olApp As Object
    Dim objNS As Object
    Dim targetFolder As Object

    On Error GoTo ErrorHandler

 Set Msg = Item
    Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
    checksub = Msg.Subject
    checksend = Msg.Sender
    checksendname = Msg.SenderName
    checksendemail = Msg.SenderEmailAddress
    checkbod = Msg.Body
    checkto = Msg.To
    checkbcc = Msg.BCC
    checkcc = Msg.CC
    checkcreation = Msg.CreationTime
    checksize = Msg.Size

'Classes Folder
        If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
        Or checksend Like "*Award*eBooks*" Then
                Set targetFolder = PST.Folders("Education").Folders("Classes")
                Msg.Move targetFolder
                GoTo ProgramExit
        End If

If targetFolder Is Nothing Then
        GoTo ProgramExit
'    Else
'        Msg.Move targetFolder
    End If

'    Set olApp = Nothing
'    Set objNS = Nothing
    Set targetFolder = Nothing
    Set checksub = Nothing
    Set checksend = Nothing


ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

1 Ответ

0 голосов
/ 18 сентября 2018

Попробуйте этот код: 

Sub MoveToFolder()

Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")


For M = 1 To olArcFolder.items.Count
    Set myItem = olArcFolder.items(M)
    myItem.Display
    Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
    Set myCopiedInspectors = myInspectors.copy
    myCopiedInspectors.Move olCompFolder
    myInspectors.Close olDiscard
Next M

Вот ссылка для справки:

Сделайте для всех открытых писем и перейдите в папку

...