Remove From My Forums

VBA Code

Question
0

Sign in to vote
I'm not very good with VBA, but I'm slowly learning. I was wondering if someone could help me with some code in Outlook VBA. I'm trying to do the following under one Macro button for SPAM messages:

1.) Add the Sender and Recipient of a currently selected message to an Excel File (on a network share) in separate columns.

2.) Take the selected message add it as an attachment to a new message and forward it to an email address and delete the message from their inbox.

I already have the code for #2, but I can't seem to figure out how incorporate #1 into number #2.

Code for #2
Sub ForwardAndDeleteSpam()
'
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
'

Set objItem = GetCurrentItem()
Set objMsg = Application.CreateItem(olMailItem)

With objMsg
.Attachments.Add objItem, olEmbeddeditem
.Subject = "BLOCK SPAM FOR ME"
.To = "somebody@domain.com"
.Send
End With
objItem.Delete

Set objItem = Nothing
Set objMsg = Nothing
End Sub

Function GetCurrentItem() As Object
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = Application.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = Application.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function

Any help would be greatly appreciated.
- Moved by Aidan WangMicrosoft contingent staff Monday, August 5, 2019 1:25 AM
Friday, August 2, 2019 12:50 PM

Answers

We do have to open the workbook to write data into it. Here is a modified version:

Sub ForwardAndDeleteSpam()
'
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
'
    ' Change the filename and path!
    Const strWorkbook = "Spammers.xlsx"
    Const strPath = "\\share\folder\subfolder\"

    Dim objItem As Object
    Dim objMsg As Object
    Dim objXls As Object
    Dim objWbk As Object
    Dim objWsh As Object
    Dim lngRow As Long
    Dim blnXls As Boolean
    Dim blnWbk As Boolean

    Set objItem = GetCurrentItem()

    On Error Resume Next
    Set objXls = GetObject(Class:="Excel.Application")
    If objXls Is Nothing Then
        Set objXls = CreateObject(Class:="Excel.Application")
        blnXls = True
    End If
    Set objWbk = objXls.Workbooks(strWorkbook)
    If objWbk Is Nothing Then
        Set objWbk = objXls.Workbooks.Open(strPath & strWorkbook)
        blnWbk = True
    End If
    On Error GoTo 0
    Set objWsh = objWbk.Worksheets(1)
    lngRow = objWsh.Range("A" & objWsh.Rows.Count).End(-4162).Row + 1
    objWsh.Range("A" & lngRow).Value = objItem.Sender
    objWsh.Range("B" & lngRow).Value = objItem.To
    If blnWbk Then
        objWbk.Close SaveChanges:=True
    Else
        objWbk.Save
    End If
    If blnXls Then
        objXls.Quit
    End If

    Set objMsg = Application.CreateItem(olMailItem)
  
    With objMsg
        .Attachments.Add objItem, olEmbeddeditem
        .Subject = "BLOCK SPAM FOR ME"
        .To = "somebody@domain.com"
        .Send
    End With
    objItem.Delete

    Set objItem = Nothing
    Set objMsg = Nothing
End Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Edited by Hans Vogelaar MVPMVP Friday, August 2, 2019 2:01 PM
Marked as answer by TheOriginalHB3 Friday, August 2, 2019 3:13 PM

Friday, August 2, 2019 2:00 PM

All replies

Here is an expanded version of ForwardAndDeleteSpam. This version leaves the workbook open, but it can easily be modified to close the workbook

Sub ForwardAndDeleteSpam()
'
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
'
    ' Change the filename and path!
    Const strWorkbook = "Spammers.xlsx"
    Const strPath = "\\share\folder\subfolder\"

    Dim objItem As Object
    Dim objMsg As Object
    Dim objXls As Object
    Dim objWbk As Object
    Dim objWsh As Object
    Dim lngRow As Long

    Set objItem = GetCurrentItem()

    On Error Resume Next
    Set objXls = GetObject(Class:="Excel.Application")
    If objXls Is Nothing Then
        Set objXls = CreateObject(Class:="Excel.Application")
    End If
    Set objWbk = objXls.Workbooks(strWorkbook)
    If objWbk Is Nothing Then
        Set objWbk = objXls.Workbooks.Open(strPath & strWorkbook)
    End If
    On Error GoTo 0
    Set objWsh = objWbk.Worksheets(1)
    lngRow = objWsh.Range("A" & objWsh.Rows.Count).End(-4162).Row + 1
    objWsh.Range("A" & lngRow).Value = objItem.Sender
    objWsh.Range("B" & lngRow).Value = objItem.To
    objWbk.Save
    objXls.Visible = True

    Set objMsg = Application.CreateItem(olMailItem)
  
    With objMsg
        .Attachments.Add objItem, olEmbeddeditem
        .Subject = "BLOCK SPAM FOR ME"
        .To = "somebody@domain.com"
        .Send
    End With
    objItem.Delete

    Set objItem = Nothing
    Set objMsg = Nothing
End Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Friday, August 2, 2019 1:08 PM

0

Sign in to vote

This is a huge help, thank you so much! Is there way it doesn't have to open the excel file on the computer, but just add to the file? If no, how do you have the excel file just close automatically? Again, thank you so much for all your help so far.

Friday, August 2, 2019 1:44 PM

We do have to open the workbook to write data into it. Here is a modified version:

Sub ForwardAndDeleteSpam()
'
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
'
    ' Change the filename and path!
    Const strWorkbook = "Spammers.xlsx"
    Const strPath = "\\share\folder\subfolder\"

    Dim objItem As Object
    Dim objMsg As Object
    Dim objXls As Object
    Dim objWbk As Object
    Dim objWsh As Object
    Dim lngRow As Long
    Dim blnXls As Boolean
    Dim blnWbk As Boolean

    Set objItem = GetCurrentItem()

    On Error Resume Next
    Set objXls = GetObject(Class:="Excel.Application")
    If objXls Is Nothing Then
        Set objXls = CreateObject(Class:="Excel.Application")
        blnXls = True
    End If
    Set objWbk = objXls.Workbooks(strWorkbook)
    If objWbk Is Nothing Then
        Set objWbk = objXls.Workbooks.Open(strPath & strWorkbook)
        blnWbk = True
    End If
    On Error GoTo 0
    Set objWsh = objWbk.Worksheets(1)
    lngRow = objWsh.Range("A" & objWsh.Rows.Count).End(-4162).Row + 1
    objWsh.Range("A" & lngRow).Value = objItem.Sender
    objWsh.Range("B" & lngRow).Value = objItem.To
    If blnWbk Then
        objWbk.Close SaveChanges:=True
    Else
        objWbk.Save
    End If
    If blnXls Then
        objXls.Quit
    End If

    Set objMsg = Application.CreateItem(olMailItem)
  
    With objMsg
        .Attachments.Add objItem, olEmbeddeditem
        .Subject = "BLOCK SPAM FOR ME"
        .To = "somebody@domain.com"
        .Send
    End With
    objItem.Delete

    Set objItem = Nothing
    Set objMsg = Nothing
End Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Edited by Hans Vogelaar MVPMVP Friday, August 2, 2019 2:01 PM
Marked as answer by TheOriginalHB3 Friday, August 2, 2019 3:13 PM

Friday, August 2, 2019 2:00 PM

0

Sign in to vote

You sir are amazing, thank you so much. You saved me so much time and stress.

Friday, August 2, 2019 3:13 PM
0

Sign in to vote

Hans, one other question is there way can I turn the From: and To: field into email addresses instead of names?

Monday, August 5, 2019 5:10 PM
0

Sign in to vote

For the sender, you can change

objWsh.Range("A" & lngRow).Value = objItem.Sender

to

objWsh.Range("A" & lngRow).Value = objItem.SenderEmailAddress

For the recipient, it is tricky, since the To: box might contain multiple names. You can get the email address of the first recipient by changing

objWsh.Range("B" & lngRow).Value = objItem.To

to

objWsh.Range("B" & lngRow).Value = objItem.Recipients(1).Address
Regards, Hans Vogelaar (http://www.eileenslounge.com)

Monday, August 5, 2019 8:51 PM
0

Sign in to vote

Thanks Hans

I seem to be getting an error when running the Macro now.

I'm getting a Run-Time Error 91: Object Variable or With block variable not set

Once I debug it highlights section of code: Set objWsh = objWbk.Worksheets(1)

I verified the path to the to name of the workbook and path.

Tuesday, August 6, 2019 1:06 PM

I have added a few lines that should provide more information:

Sub ForwardAndDeleteSpam()
'
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
'
    ' Change the filename and path!
    Const strWorkbook = "Spammers.xlsx"
    Const strPath = "\\share\folder\subfolder\"

    Dim objItem As Object
    Dim objMsg As Object
    Dim objXls As Object
    Dim objWbk As Object
    Dim objWsh As Object
    Dim lngRow As Long
    Dim blnXls As Boolean
    Dim blnWbk As Boolean

    Set objItem = GetCurrentItem()

    On Error Resume Next
    Set objXls = GetObject(Class:="Excel.Application")
    If objXls Is Nothing Then
        Set objXls = CreateObject(Class:="Excel.Application")
        If objXls Is Nothing Then
            MsgBox "Unable to start Excel!", vbCritical
            Exit Sub
        End If
        blnXls = True
    End If
    Set objWbk = objXls.Workbooks(strWorkbook)
    If objWbk Is Nothing Then
        Set objWbk = objXls.Workbooks.Open(strPath & strWorkbook)
        If objWbk Is Nothing Then
            MsgBox "Unable to open " & strPath & strWorkbook, vbCritical
            If blnXls Then
                objXls.Quit
            End If
            Exit Sub
        End If
        blnWbk = True
    End If
    On Error GoTo 0
    Set objWsh = objWbk.Worksheets(1)
    lngRow = objWsh.Range("A" & objWsh.Rows.Count).End(-4162).Row + 1
    objWsh.Range("A" & lngRow).Value = objItem.Sender
    objWsh.Range("B" & lngRow).Value = objItem.To
    If blnWbk Then
        objWbk.Close SaveChanges:=True
    Else
        objWbk.Save
    End If
    If blnXls Then
        objXls.Quit
    End If

    Set objMsg = Application.CreateItem(olMailItem)

    With objMsg
        .Attachments.Add objItem, olEmbeddeditem
        .Subject = "BLOCK SPAM FOR ME"
        .To = "somebody@domain.com"
        .Send
    End With
    objItem.Delete

    Set objItem = Nothing
    Set objMsg = Nothing
End Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Tuesday, August 6, 2019 2:14 PM

Products

Resources

Solutions

Updates

Trials

Related Sites

Training

Certifications

Other resources

Support options

More support

Not an IT pro?

Answered by:

VBA Code

Question

Answers

All replies