locked
VBA Code RRS feed

  • Question

  • 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.  

    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)


    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
  • 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)


    Friday, August 2, 2019 2:00 PM
  • You sir are amazing, thank you so much.   You saved me so much time and stress.   
    Friday, August 2, 2019 3:13 PM
  • 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
  • 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
  • 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