在任务文件夹的子文件夹中创建Outlook任务项时出错

Question

我一直在使用我在堆栈溢出中发现的例程来自动在默认任务文件夹中创建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

我有一个类似的问题，也许你的问题的原因是一样的。我发现默认的收件箱不在我的ISP上加载的所有电子邮件的商店中。实际上，默认的收件箱是空的，因为它从来没有被使用过。

运行下面的宏来发现你有哪些默认文件夹以及哪个存储包含它们。

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中的正确位置创建自定义文件夹。我创建然后在收件箱下，当我应该在任务下创建它们。差异不明显。您基本上必须右键单击对象任务 - username@domain.com并选择创建新文件夹。如果您右键单击其他地方，例如，在待办事项列表中，您将在收件箱下创建文件夹。现在正在工作。