Outlook VB 脚本从电子邮件创建任务 - 不创建任务

Question

我有以下脚本，就我所见，它应该可以正常工作（事实上，昨天的某个时间点正在工作 - 但我在尝试清理代码时一定是无意中更改了一些东西，因为它不是今天工作时间更长）。

也许另一双眼睛可以帮助我。我有一个规则设置来将这些电子邮件设置到他们自己的文件夹中并在 Outlook 中运行脚本。这没有问题 - 问题来自脚本本身。

被过滤的邮件的主题通常是这样的：

“票：328157 学校：BlahBlah 问题：通量电容器问题”

这个想法是脚本将创建一个具有适当优先级的任务并将其放入适当的类别中（并且只包括主题中“学校”之后的内容，因为票号并不重要）。

这是脚本：

Sub MakeTaskFromMail(MyMail As Outlook.MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem

'Get Specific Email based on ID
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
Set objTask = Application.CreateItem(olTaskItem)
'**************************
'*****SET TASK SUBJECT*****
'**************************
Dim sInput As String
Dim sOutput As String
'get the email subject
sInput = olMail.Subject
'get all the text after School: in the subject
sOutput = Mid(sInput, InStr(sInput, "School:") + 8)

Dim priorityUrgentString As String
Dim priorityHighString As String
Dim priorityMediumString As String
Dim priorityLowString As String
'Set Priority Strings to check for to determine category
priorityUrgentString = "Priority: Urgent"
priorityHighString = "Priority: High Priority"
priorityMediumString = "Priority: Medium"
priorityLowString = "Priority: Project"
'check to see if ticket is Urgent
'if urgent - due date is today and alert is set for 8am
If InStr(olMail.Body, priorityUrgentString) <> 0 Then
    With objTask
        .Subject = sOutput
        .DueDate = olMail.SentOn
        .Body = olMail.Body
        .Categories = "Urgent"
        .Importance = olImportanceHigh
        .ReminderSet = True
        .ReminderTime = objTask.DueDate
    End With
'check to see if ticket is High Priority
'if High Priority - due date is today - alert is set for 8am
ElseIf InStr(olMail.Body, priorityHighString) <> 0 Then
    With objTask
        .Subject = sOutput
        .DueDate = olMail.SentOn + 2
        .Body = olMail.Body
        .Categories = "High"
        .Importance = olImportanceHigh
        .ReminderSet = True
        .ReminderTime = objTask.DueDate + 2
    End With
'check to see if its a medium priority
'if medium - due date is set for 7 days, no alert
ElseIf InStr(olMail.Body, priorityMediumString) <> 0 Then
    With objTask
        .Subject = sOutput
        .DueDate = olMail.SentOn + 7
        .Body = olMail.Body
        .Categories = "Medium"
        .Importance = olImportanceNormal
    End With
'check to see if its a project priority
'if project - due date is set for 21 days, no alert
ElseIf InStr(olMail.Body, priorityLowString) <> 0 Then
    With objTask
        .Subject = sOutput
        .DueDate = olMail.SentOn + 21
        .Body = olMail.Body
        .Categories = "Project"
        .Importance = olImportanceLow
    End With
End If
'Copy Attachments
Call CopyAttachments(olMail, objTask)
'Save Task
objTask.Save

Set objTask = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub

Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing
End Sub

Answer 1

不运行脚本我能看到的是这样的：

您必须在设置后保存TaskItem（使用.Save 作为With 中的最后一行）

另外，您可能需要设置与邮件项匹配的 ReminderTime

.ReminderTime = olMail.SentOn

而不是

.ReminderTime = objTask.DueDate

因为它还没有保存