Ошибка создания элемента задачи Outlook в подпапке папки задач

Question

Я использовал процедуру, которую я обнаружил в Stack Overflow, чтобы автоматически создать элемент задачи в Outlook в папке Задачи по умолчанию. Я попытался изменить его, чтобы создать задачу в одной из двух подпапок задач «Новые FTE» и «Новые консультанты».

Выполнение этого кода вызывает это сообщение от обработчика ошибок.

Номер ошибки: -2147221233

Ошибка Источник: AddOlkTask

Ошибка Описание: Предпринятая операция не удалась. Не удалось найти объект.

Код проблемы отображается между «началом нового кода и» новым кодом. Я пробовал много вариантов этого кода, но я не могу взломать его (каламбур не предназначен).

Sub AddOlTask(sSubject, sBody, dtDueDate, dtReminderDate, name, program) 
On Error GoTo Error_Handler 
Dim noDue, pFolder, reminderSetFlag As String 

reminderSetFlag = False 

If program <> "Career Path Curriculum" Then 
    dtDue = dtDueDate 
    dtReminder = dtReminderDate 
    reminderSetFlag = True 
End If 

If program = "Active Consultant" Then 
    pFolder = "New Consultants" 
    Else 
    pFolder = "New FTEs" 
End If 

Const olTaskItem = 3 
Dim olApp As Object 
Dim OlTask As Object 

Set olApp = CreateObject("Outlook.Application") 
Set OlTask = olApp.CreateItem(olTaskItem) 

With OlTask 
    .Subject = name & ": " & sSubject 
    .Status = 1     '0=not started, 1=in progress, 2=complete, 3=waiting, 
           '4=deferred 
    .Importance = 1    '0=low, 1=normal, 2=high 
    .dueDate = dtDue 
    .ReminderSet = reminderSetFlag 
    .ReminderTime = dtReminder 
    .Categories = "Mandatory SkillSoft Training" 'use any of the predefined Categorys or create your own 
    .body = sBody 
    .Display 
    .Save 

End With 

'start new code 
Dim objNS As Outlook.NameSpace 
Dim olFolder As Outlook.MAPIFolder 
Dim tsk As Outlook.TaskItem 

Set olApp = Outlook.Application 
Set objNS = olApp.GetNamespace("MAPI") 
Set olFolder = objNS.GetDefaultFolder(olFolderTasks) 
Set olFolder = olFolder.Folders(pFolder) 'error raised on this line 
'end new code 

Error_Handler_Exit: 
    On Error Resume Next 
    Set OlTask = Nothing 
    Set olApp = Nothing 
Exit Sub 

Error_Handler: 
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & "Error Number: " & _ 
    Err.Number & vbCrLf & "Error Source: AddOlkTask" & vbCrLf & "Error Description: " & _ 
    Err.Description, vbCritical, "An Error has Occurred!" 
    Resume Error_Handler_Exit 

End Sub 

Answer 1

У меня была подобная проблема, и возможно, причиной вашей проблемы является то же самое. Я обнаружил, что по умолчанию Inbox не был в магазине, в который были загружены все мои электронные письма от моего интернет-провайдера. По умолчанию Inbox был пустым, потому что он никогда не использовался.

Запустите макрос ниже, чтобы узнать, какие папки по умолчанию у вас есть и в каком хранилище их содержится.

Sub DsplUsernameOfDefaultStores() 

    Dim NS As Outlook.NameSpace 
    Dim DefaultFldr As MAPIFolder 
    Dim FldrTypeNo() As Variant 
    Dim FldrTypeName() As Variant 
    Dim InxFldr As Long 

    Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI") 

    FldrTypeNo = VBA.Array(olFolderCalendar, olFolderConflicts, olFolderContacts, _ 
         olFolderDeletedItems, olFolderDrafts, olFolderInbox, _ 
         olFolderJournal, olFolderJunk, olFolderLocalFailures, _ 
         olFolderManagedEmail, olFolderNotes, olFolderOutbox, _ 
         olFolderSentMail, olFolderServerFailures, _ 
         olFolderSuggestedContacts, olFolderSyncIssues, olFolderTasks, _ 
         olPublicFoldersAllPublicFolders, olFolderRssFeeds) 

    FldrTypeName = VBA.Array("Calendar", "Conflicts", "Contacts", _ 
          "DeletedItems", "Drafts", "Inbox", _ 
          "Journal", "Junk", "LocalFailures", _ 
          "ManagedEmail", "Notes", "Outbox", _ 
          "SentMail", "ServerFailures", _ 
          "SuggestedContacts", "SyncIssues", "Tasks", _ 
          "AllPublicFolders", "RssFeeds") 

    Debug.Print "Stores containing default folders" 
    For InxFldr = 0 To UBound(FldrTypeNo) 
    Set DefaultFldr = Nothing 
    On Error Resume Next 
    Set DefaultFldr = NS.GetDefaultFolder(FldrTypeNo(InxFldr)) 
    On Error GoTo 0 
    If DefaultFldr Is Nothing Then 
     Debug.Print "No default " & FldrTypeName(InxFldr) 
    Else 
     Debug.Print "Default " & FldrTypeName(InxFldr) & " in """ & DefaultFldr.Parent.Name & """" 
    End If 
    Next 

End Sub 

Вторая попытка идентифицировать проблему

Я добавил две подпапки в мои папки задач, а затем используется следующий макрос, чтобы успешно показывать их имена.

Я использовал Session вместо GetNamespace("MAPI"). Они должны быть эквивалентными, но у меня когда-то было Session, когда GetNamespace("MAPI") не сделал. Я не помню подробностей, и я не исследовал, так как был счастлив использовать Session.

Вам нужно будет внести поправку в свой оператор Set Fldr ..., если папка «Задачи» находится не в том же месте, что и у меня. Вы можете использовать Set Fldr = Session.GetDefaultFolder(olFolderTasks), если хотите.

Я отобразил имена с квадратными скобками вокруг них, чтобы выделить любые пробелы в пределах имени.

Sub DsplTaskFolders() 

    Dim Fldr As Folder 
    Dim InxTskFldrCrnt 

    Set Fldr = Session.Folders("Outlook data file").Folders("Tasks") 

    For InxTskFldrCrnt = 1 To Fldr.Folders.Count 
    Debug.Print "[" & Fldr.Folders(InxTskFldrCrnt).Name & "]" 
    Next 

End Sub 

Answer 2

Еще раз спасибо Тони. Вы код помогли мне понять эту проблему. Я не создавал пользовательские папки в правильном месте в Outlook. Я создал его под Inbox, когда я должен был создать их под Tasks. Разница не очевидна. В основном вы должны щелкнуть правой кнопкой мыши по объекту Задачи - имя_пользователя@domain.com и выберите «Создать новую папку». Если вы щелкните правой кнопкой мыши в другом месте, например, в списке дел, вы создадите папку в папке «Входящие». Теперь работает.