Macro to Forward Multiple Emails as attachments

Question

I have a macro which I had working on a PC, but just did a fresh install of Windows and Office 2010.

Now the macro doesnt want to run, producing an error.

 

Sub SpamAssassin()
    
    Dim ns As NameSpace
    Set ns = Application.GetNamespace("MAPI")
    Set objJunk = ns.GetDefaultFolder(olFolderJunk).Items
    
    'Assign the email address to forward items to
    Dim msgAssassin As String
    msgAssassin = [e-mail]

    
    Dim objMail As Object
    Dim objNewMail As Object
    
    'Assign variable to delete items
    Dim i As Long
    Dim objJunkFolder As Outlook.Folder
    Dim objJunkMail As Outlook.Items
    Set objJunkFolder = ns.GetDefaultFolder(olFolderJunk)
    Set objJunkMail = objJunkFolder.Items
    
    Set objNewMail = Application.CreateItem(olMailItem)

    
    'Forward each item as attachment
    For Each objMail In objJunk
    objNewMail.Attachments.Add objMail
    Next

    
    'Delete item from Junk E-mail Folder
    For i = objJunkMail.Count To 1 Step -1
    objJunkMail.Remove i
    Next

    objNewMail.To = msgAssassin
    objNewMail.Subject = "Reporting Items"
    objNewMail.Display

    
Set objJunk = Nothing
Set objMail = Nothing
Set objNewMail = Nothing

End Sub

 

I am getting the error at the Loop

    'Forward each item as attachment
    For Each objMail In objJunk
    objNewMail.Attachments.Add objMail  :: Run-time error '-2117221233(8004010f)': The attempted operation failed. An Object could not be found.
    Next

 

Any advice and assistance would be greatly appreciated.

 Thanks

Craig

Answer 1

Hello,

The macro below works fine for me. That is, I've added the declaration for objJunk and corrected the value assigned to msgAssassin.

Sub SpamAssassin()
    Dim objJunk As Items
    Dim ns As NameSpace
    Set ns = Application.GetNamespace("MAPI")
    Set objJunk = ns.GetDefaultFolder(olFolderJunk).Items
    
    'Assign the email address to forward items to
    Dim msgAssassin As String
    msgAssassin = "[e-mail]"
     
    Dim objMail As Object
    Dim objNewMail As Object
    
    'Assign variable to delete items
    Dim i As Long
    Dim objJunkFolder As Outlook.Folder
    Dim objJunkMail As Outlook.Items
    Set objJunkFolder = ns.GetDefaultFolder(olFolderJunk)
    Set objJunkMail = objJunkFolder.Items
    
    Set objNewMail = Application.CreateItem(olMailItem)
     
    'Forward each item as attachment
    For Each objMail In objJunk
        objNewMail.Attachments.Add objMail
    Next
     
    'Delete item from Junk E-mail Folder
    For i = objJunkMail.Count To 1 Step -1
        objJunkMail.Remove i
    Next

    objNewMail.To = msgAssassin
    objNewMail.Subject = "Reporting Items"
    objNewMail.Display

    
Set objJunk = Nothing
Set objMail = Nothing
Set objNewMail = Nothing

End Sub

---

Regards from Belarus (GMT + 2),

Andrei Smolin
Add-in Express Team Leader

Answer 2

Thankyou very much.

I got up this morning and ran the macro, before making the changes and it worked.  odd.

Anyway, i added the new line (Dim objJunk As Items) as i guess thats what was giving me the error to start with.  The quotes around the email address was just a paste error.

Thanks for your quick response. Very much appreciated.

Regards

Craig

Answer 3

i tried the above code as i need in a same need, but i get a syntax error at the END SUB line. i am a new bee to this

please help with this.

Sub ATSBI()
    Dim ATSBImails As Items
    Dim ns As NameSpace
    Set ns = Application.GetNamespace("MAPI")
    Set ATSBImails = ns.GetDefaultFolder(Voice).Items
    
    'Assign the email address to forward items to
    Dim ATSBIRecipient As String
    ATSBIRecipient = "[e-mail]"
     
    Dim objMail As Object
    Dim objNewMail As Object
    
    'Assign variable to delete items
    Dim i As Long
    Dim objFolder As Outlook.Folder
    Dim obMail As Outlook.Items
    Set obFolder = ns.GetDefaultFolder(Voice)
    Set obMail = obFolder.Items
    
    Set objNewMail = Application.CreateItem(olMailItem)
     
    'Forward each item as attachment
    For Each objMail In ATSBImails
        objNewMail.Attachments.Add objMail
    Next
     
    'Delete item from Junk E-mail Folder
    For i = obMail.Count To 1 Step -1
        obMail.Remove i
    Next

    objNewMail.To = ATSBIRecipient
    objNewMail.Subject = "Reporting Items"
    objNewMail.Display

    
Set objJunk = Nothing
Set objMail = Nothing
Set objNewMail = Nothing

End Sub

Answer 4

i have also changed

Set objJunk = Nothing
to 
Set ATSBImails= Nothing