ThisOutlookSession - Question

[Steve885]

Hi All,

I have just added the top half of this code to 'ThisOutlookSession', and whilst it works fine, the second sub doesn't work at all now. What have I don't wrong? Any help appreciated.

Private Sub Application_ItemSend(ByVal Item As Object, _
                                 Cancel As Boolean)
    Dim objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    On Error Resume Next
    ' #### USER OPTIONS ####
    ' address for Bcc -- must be SMTP address
    ' or resolvable to a name in the address book
    strBcc = "[email protected]"
    Set objRecip = Item.Recipients.Add(strBcc)
    objRecip.Type = olBCC
    If Not objRecip.Resolve Then
        strMsg = "Could not resolve the Bcc recipient. " & _
                 "Do you want to send the message?"
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
                "Could Not Resolve Bcc")
        If res = vbNo Then
            Cancel = True
        End If
    End If
    Set objRecip = Nothing
End Sub

Sub SaveACopy(Item As Object)
    Const olMsg As Long = 3

    Dim m As MailItem
    Dim savePath As String

    If TypeName(Item) <> "MailItem" Then Exit Sub

    Set m = Item

    savePath = "S:\Sales & Marketing\Sales\Correspondence\"
    savePath = savePath & m.To & "_" & Format(Now(), "yyyy-mm-dd-hhNNss")
    savePath = savePath & ".msg"


    m.SaveAs savePath, olMsg

End Sub