To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx
You are repeatedly using the first item in the selection.
Set objItem = GetCurrentItem() is not needed.
Sub PrintWithBCC()
Dim objItem As Object
Dim objProp As Outlook.UserProperty
Dim objselection As Outlook.Selection
' Do not use when you are debugging and rarely ever
' On Error Resume Next
Set objselection = ActiveExplorer.Selection
For Each objItem In objselection
Set objItem = GetCurrentItem()
Debug.Print objItem.Subject ' <----
If objItem.MessageClass = "IPM.Note" Then
Set objProp = objItem.UserProperties("BCC List")
If objProp Is Nothing Then
Set objProp = objItem.UserProperties.Add("BCC List", olText, True)
End If
objProp.Value = objItem.BCC
objItem.Save
End If
Next objItem
Set objItem = Nothing
Set objProp = Nothing
MsgBox "done"
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
End Select
Set objApp = Nothing
End Function
You should see a # button to wrap code tags around your code.