categories for outgoing email

[Iqbal Khan]

I am trying to set categories to outgoing email in Outlook 2016 based on certain combo box values from the end user.

I am using the below code to add category to outgoing email within the Item send event.

msg.Categories = msg.Categories & "," & EmailDetails.cmbresponsetype.Value & "-" & EmailDetails.cmblbl.Value & "-" & grp
msg.Save

The above works sometimes but most of the time it does nothing.

Please help

 

[Diane Poremsky]

does it trigger any errors? (comment out any error handlers you are using )

add a message box (or debug.print) - does it show the values?

msgbox EmailDetails.cmbresponsetype.Value & "-" & EmailDetails.cmblbl.Value
msg.Categories = msg.Categories & "," & EmailDetails.cmbresponsetype.Value & "-" & EmailDetails.cmblbl.Value & "-" & grp
msg.Save

add debug.print lines after each step - check the immediate window- are they all entered?

 

[Iqbal Khan]

It gives no errors.

I check the code using the step mode, all form values shows but no categories is set for the email.

However sometimes if I run the code in step mode it sets the category but when I run the code it gives blank.

I tried using sleep after the first line of code but no luck.

 

[Diane Poremsky]

can you post the entire macro? I'll test it and see if i can repro.

 

[Iqbal Khan]

I tested the code again and found that when the email is replied within the reading pane it categories the email but when I open the email in a new window it does not categories it.

I will send you relevant code in sometime.

Thank you.

 

[Diane Poremsky]

Definitely weird - its usually the other way around - macros apply to open mail, not reading pane compose.

 

[Iqbal Khan]

Hi Diane,

Please find below the code I am using to set the categories.

Thank you for your help.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If EmailDetails.Visible = False Then
    clrform
End If
    Flag = True
    Dim strSubject As String
Dim tempMsg As mailItem
If TypeName(Item) = "MailItem" Then
    Set tempMsg = FindParentMessage(Item)
End If
    Set m_Inspector = Application.ActiveInspector
    If TypeName(Item) = "MailItem" Then
        Set msg = GetCurrentItem()
    Else
        Exit Sub
    End If
    strDefaultStore = msg.Session.DefaultStore.DisplayName
    strSubject = msg.Subject
    NewSubject = strSubject
    If UCase(Left(NewSubject, 3)) = "RE:" Or UCase(Left(NewSubject, 3)) = "FW:" Then
        NewSubject = Trim(Replace(NewSubject, "RE:", ""))
        NewSubject = Trim(Replace(NewSubject, "FW:", ""))
    End If

    If InStr(1, strSubject, "Inbox_Job_Id:") <> 0 Then
        Dim LPosition As Integer
        LPosition = InStr(1, strSubject, "Inbox_Job_Id:")
        NewSubject = Trim(Left(NewSubject, LPosition - 2))
    End If
    esendrAc = msg.SendUsingAccount
    If esendrAc = "" Or esendrAc = strDefaultStore Then
        esendr = msg.SenderName
        If esendr = "" Then esendr = msg.SenderEmailAddress
    Else
        esendr = esendrAc
    End If
    On Error GoTo 0
   If strDefaultStore <> esendr And esendr <> "" Then
        If (EmailDetails.cmbresponsetype = "Acknowledged" Or EmailDetails.cmbresponsetype = "Follow-up" Or EmailDetails.cmbresponsetype = "In Progress") _
        And EmailDetails.txtfollowup = vbNullString Then
            MsgBox "Please enter Follow-up Date"
            EmailDetails.Show
            Cancel = True
        End If
       If IsNull(EmailDetails.cmblbl.Value) = True Or EmailDetails.cmblbl.Value = "" Or EmailDetails.cmbresponsetype.Value = "" _
        Or EmailDetails.cmbTask.Value = "" Then
            MsgBox "Please enter details in form to continue" & Chr(13) & "OR" & Chr(13) & "Please check vendor details"
            EmailDetails.Show
            EmailDetails.txtfollowup.Enabled = False
            EmailDetails.txtteamname = esendrAc
            EmailDetails.txtteamname.Locked = True
            EmailDetails.txtSub.Value = strSubject
            EmailDetails.txtdate.Value = Format(Now(), "DD-MMM-YYYY")
            EmailDetails.txttime.Value = Format(Now(), "HH:MM:SS")
            EmailDetails.txtuname.Value = Environ("Username")
            EmailDetails.txtfollowup.Value = EmailDetails.txtfollowup.Value
            EmailDetails.cmblbl.Value = EmailDetails.cmblbl.Value
            EmailDetails.cmbresponsetype.Value = EmailDetails.cmbresponsetype.Value
            EmailDetails.txtcomments.Value = EmailDetails.txtcomments.Value
           EmailDetails.cmbTask.Value = EmailDetails.cmbTask.Value
            Cancel = True
            Else
            Item.Save   

            Dim convid As String
            If tempMsg Is Nothing Then
                convid = msg.ConversationID
            Else
                convid = tempMsg.ConversationID
            End If

            Call modUpData.Upload(Item, convid)
            EmailDetails.Hide
            Application_Startup 
           
            Set olApp = Outlook.Application
            Set objNS = olApp.GetNamespace("MAPI")
           
            If UID <> "" Then Set msginbx = objNS.GetItemFromID(UID)
            Dim arr
            Dim i As Integer
            'If InStr(1, UCase(strSubject), UCase(USUB)) <> 0 And UID <> "" Then
            If InStr(1, UCase(msg.Subject), UCase(NewSubject)) <> 0 And UID <> "" Then
                arr = Split(msg.Categories, ",")
                If UBound(arr) >= 0 Then
                    For i = 0 To UBound(arr)
                      If Trim(arr(i)) = "No Action Required" Or Trim(arr(i)) = "Acknowledged" Or Trim(arr(i)) = "Resolved / Completed" Or Trim(arr(i)) = "In Progress" Or Trim(arr(i)) = "Follow-up" Then
                        ' remove it
                            arr(i) = ""
                            msg.Categories = Join(arr, ",")
                        End If
                        Next
                    End If
                   
                ' Category not found, add it
                msg.Categories = msginbx.Categories & "," & EmailDetails.cmbresponsetype.Value
                msg.Save
            Else
                    Set UItems = objNS.Folders(strDefaultStore).Folders("Inbox").Items
                    For Each UMail In UItems
                        'If InStr(1, UMail.Subject, Mid(strSubject, intStart, intSub)) <> 0 Then
                        If InStr(1, UCase(UMail.Subject), UCase(NewSubject)) <> 0 Then
                            arr = Split(UMail.Categories, ",")
                            If UBound(arr) >= 0 Then
                            ' Check for Category
                                For i = 0 To UBound(arr)
                                  If Trim(arr(i)) = "No Action Required" Or Trim(arr(i)) = "Acknowledged" Or Trim(arr(i)) = "Resolved / Completed" Or Trim(arr(i)) = "In Progress" Or Trim(arr(i)) = "Follow-up" Then
                                    ' remove it
                                        arr(i) = ""
                                        UMail.Categories = Join(arr, ",")
                                    End If
                                    Next
                                End If
                            ' Category not found, add it
    If EmailDetails.Grp1 = True Then
        grp = "Group One"
    ElseIf EmailDetails.Grp2 = True Then
        grp = "Group Two"
    ElseIf EmailDetails.Grp3 = True Then
        grp = "Group Three"
    End If
                            UMail.Categories = UMail.Categories & "," & EmailDetails.cmbresponsetype.Value & "-" & EmailDetails.cmblbl.Value & "-" & grp
                            UMail.Save
                            Exit For
                        End If
                Next UMail
            End If
        End If
    End If
End Sub

 

[Iqbal Khan]

I solved the issue, actually the categories were getting set for emails in Sent Items and not in the inbox. I removed the one which sets the category for current message and used .find to find the email I am replying with the subject and set the category to the email in Inbox.

Thank you