Создание задачи из отправляемого элемента на основе текста в теме

Question

Я автоматизирую создание задач в Outlook.

Я хочу, чтобы этот код спрашивал, хочу ли я создать задачу после того, как я нажму кнопку Отправить электронную почту. Я хочу, чтобы он спрашивал только, есть ли конкретный заголовок в письме. Мы используем "# CT-" в качестве обозначения для создания задачи.

Оригинальный код можно найти здесь:

https://www.slipstick.com/developer/code-samples/create-task-sending-message/

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
Dim itm As MailItem

With itm
    .subject = "#CT-"
End With

If itm.subject Like "#CT-" Then
    strMsg = "Do you want to create a task for this message?"
    intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
End If

If intRes = vbNo Then
    Cancel = False
Else

    For Each Recipient In Item.Recipients
        strRecip = strRecip & vbCrLf & Recipient.Address
    Next Recipient

    With objTask
        .Body = Item.Body
        .subject = Item.subject
        .DueDate = Item.ReceivedTime + 28
        .ReminderSet = True
        .ReminderTime = Item.ReceivedTime + 7
        .Save
    End With

    Cancel = False

End If

Set objTask = Nothing

End Sub

Answer 1

Очень близко Действительно, вы можете использовать тот же код, однако

1.Вы должны сохранить объект в strSubject, используя Item.Subject свойство

2. Сравните результат с "#CT ​​-"

3.Если сравнение прошло успешно, укажите, какое действие необходимо выполнить.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
Dim itm As MailItem
Dim strSubject As String

strSubject = Item.Subject



  If strSubject Like "#CT-" Then
    strMsg = "Do you want to create a task for this message?"
    intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
  End If

    If intRes = vbNo Then
      Cancel = False

    Else

    For Each Recipient In Item.Recipients
        strRecip = strRecip & vbCrLf & Recipient.Address
    Next Recipient

With objTask
    .Body = Item.Body
    .subject = Item.subject
    .DueDate = Item.ReceivedTime + 28
    .ReminderSet = True
    .ReminderTime = Item.ReceivedTime + 7
    .Save
End With

Answer 2

Вам не нужен новый itm - вы хотите работать с параметром Item, чтобы увидеть, начинается ли его subject с вашего обозначения. Вы можете использовать функцию Left на этом subject, чтобы проверить, соответствует ли она вашему значку.

РЕДАКТИРОВАТЬ: Если вы хотите сохранить задачу в папке, отличной от папки «Список дел» по умолчанию, вы можете .Move после ее сохранения.

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strSignifier As String
Dim ns As Outlook.NameSpace
Dim inquiries As Folder

Set ns = Application.GetNamespace("MAPI")

On Error GoTo FolderError:
' Inquiries is a subfolder of Inbox
Set inquiries = ns.GetDefaultFolder(olFolderInbox).Folders("Inquiries")
On Error GoTo 0

strSignifier = "#CT-"
strMsg = "Do you want to create a task for this message?"

If TypeOf Item Is Outlook.MailItem Then
    If Left(Item.Subject, Len(strSignifier)) = strSignifier Then
        If MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task") = vbYes Then
            With objTask
                .Body = Item.Body
                .Subject = Item.Subject
                .DueDate = Item.ReceivedTime + 28
                .ReminderSet = True
                .ReminderTime = Item.ReceivedTime + 7
                .Save 'to default folder
                .Move inquiries
            End With
        End If
    End If
End If

Set objTask = Nothing
Exit Sub

FolderError:
    MsgBox "Unable to find the Inquiries folder - cannot save this email as a task."

End Sub