Can't populate Companies field of an email

[WCPeterson]

I am trying to organize my email better. I am wanting to populate the 'Companies' field of emails with a project name and then sort into folders based on that field. Most of my emails are replies to my emails, so setting this field will allow me to quickly sort. My problem is that I want to select multiple emails and set the Companies field. However, the code below only sets the first email's Companies field and not the rest. The MsgBox shows that the email appears to get set but when the macro completes the first email isn't populated until you select a new email, but only the first email is populated. None of the others get populated.

Would anybody have a solution to this?

Note: If you go to View Settings -> Columns, setting 'All Journal fields' and then Add 'Company', this field will show up as a field in your list of emails.


Sub PopulateCompaniesField()
Dim olNS As Outlook.NameSpace
Dim objSelection As Outlook.Selection
Dim objMsg As Object
Dim i As Integer

Set olNS = GetNamespace("MAPI")

' Get the collection of selected objects.
Set objSelection = Application.ActiveExplorer.Selection

For i = 1 To objSelection.Count
objSelection.Item(i).Companies = "Test"
MsgBox i & " " & objSelection.Item(i).Companies
Next i

End Sub

[WCPeterson]

I guess just posting the problem helped me solve it myself. Somehow I came across a link discussing journal entries and it included the nugget of saving a journal. I added the line below and it solved my problem:
objSelection.Item(i).Save

[WCPeterson]

I am know trying to get it to allow me to populate all the company field in all emails in a specific folder.This code gets access to all the emails, but has the same behavior as previously, where only one of the emails gets updated. This time the Save doesn't seem to work.

Would anybody know what is wrong this time?

Thanks in advance.

Sub PopulateCurrentFolderCompaniesField()
Dim olNS As Outlook.NameSpace
Dim j As Integer
Dim olCurrentFldr As Outlook.MAPIFolder
Set olNS = GetNamespace("MAPI")
Set olCurrentFldr = Application.ActiveExplorer().currentFolder
For j = 1 To olCurrentFldr.Items.Count
olCurrentFldr.Items.Item(j).Companies = "test"
olCurrentFldr.Items.Item(j).UnRead = False
olCurrentFldr.Items.Item(j).Save
MsgBox j & ":" & olCurrentFldr.Items.Item(j).Companies
Next j
End Sub