Подпапки нестандартного почтового ящика не найдены при повторном запуске кода ItemAdd - PullRequest
Новая
       12

Подпапки нестандартного почтового ящика не найдены при повторном запуске кода ItemAdd

0 голосов
/ 24 октября 2018

У нас есть общий почтовый ящик, и каждому человеку назначается папка.Как только человек заканчивает работу с электронным письмом, он / она перетаскивает его в готовую папку, которая вызывает код ItemAdd, который назначает следующую почту в папке «Входящие» папке.

Это работает в Office 2016. В Office 365 это работаетпервый раз, второй раз он ломается.

Я попытался перезапустить OLE Automation в ссылках.Я также попытался изменить объявленные переменные.

Функция GetFolderPath находится в модуле.

Я обнаружил, что objinbox.Folders.Count в первый раз возвращает количество папок в папке входящих (6).Второй раз objinbox.Folders.Count равен 0 и, следовательно, он не запускает цикл For Each olFolder In objinbox.Folders.Также проверяется, что objinbox.parent возвращает тестирование GL. 

Option Explicit
Private WithEvents inboxItems As Outlook.Items

Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace
  Dim objWatchFolder As Outlook.Folder
  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set objWatchFolder = GetFolderPath("gl testing\Completed")
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
'On Error GoTo ErrorHandler:
Dim objinbox As Outlook.MAPIFolder
Dim olFolder As Outlook.MAPIFolder
Dim objSubfolder As Outlook.MAPIFolder
Dim objEmail As Outlook.MailItem
Dim objCopy As Outlook.MailItem
Dim oMail As Outlook.MailItem
Dim moveFolder As String

Set objinbox = GetFolderPath("gl testing\Inbox")

For Each olFolder In objinbox.Folders

    If olFolder.Items.Count = 0 Then moveFolder = olFolder.Name Else

Next olFolder

Set objSubfolder = objinbox.Folders(moveFolder)

restart:
For Each oMail In objinbox.Items

    If oMail.Sender = "GL Testing" Then
        oMail.Move GetFolderPath("gl testing\WIP")

        GoTo restart

    End If

    On Error Resume Next
    If UCase(oMail.Subject) Like "*URGENT*" Then
        Set objEmail = oMail
        GoTo urgent
    End If

    On Error GoTo 0

Next oMail

If objEmail Is Nothing Then
    Set objEmail = objinbox.Items.GetFirst
End If

urgent:

Set objCopy = objEmail.Copy
objCopy.Move GetFolderPath("gl testing\Track")
objEmail.Move objSubfolder

Exit Sub
'ErrorHandler:MsgBox "No e-mail has been moved to your folder either inbox is empty or you already have another mail in your folder"

End Sub

Функция получения пути к папке. 

' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder

    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function
...