VBA code to remove attachments

[stevewood1]

Hello,

Can anyone help me with some VBA code that will remove attachments from a generated email? When I've looked online I've found examples that run in Outlook through an inbox but I have a Macro on an excel form that automatically generates an email and because I've used .HTML body to specify a font size, where individual users have pictures on their signature block it's adding them on as an attachment.

I need some code that will remove these attachments but will still allow me to email the excel workbook as an attachment which was the reason for the form.

Many thanks,

Steve

 

[sijpie]

Dim atA As Attachment


For Each atA In OutMail ' <<<< Modify OutMail to the email object name you have
    atA.Delete
Next atA

 

[stevewood1]

Hi, thanks for your response. When you say modify OutMail to the email object. The issue I have is that the file name is always different a mix of letters and numbers and when you click on the properties it shows as file type FILE. Would this cause a problem with defining it in code?

 

[sijpie]

What code do you have a t the moment? I am assuming you have code that generates the email. And a variable will have been set to this email, so you can set up the address line, subject line and add the attachment. That variable is the one I mean. Post your code if you are unsure. (use the code tags when you post code, see below in red/blue how to do that)

 

[stevewood1]

I presumed from your answer that I would need to change the line to In OutLookMail but that gave me an error 'User defined type not defined.' I have attached the code below. I want the Macro to email a copy of the workbook. I had to use .HTMLBody to specify a font size as we came across an issue where some users emails were automatically setting to font size 1465 so I added the code to make sure this didn't happen but this has meant that any user who has a picture in their signature block gets additional attachments on the email so I wanted to write into the code to delete all of the attachments before adding the workbook as an attachment and sending the email. I have attached the code below. Many thanks for your help.

 Sub Bevel1_Click()
Dim sh As Worksheet
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim signature As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
   Set OutlookApp = GetObject(, "Outlook.Application")
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Set OutlookApp = CreateObject("Outlook.Application")
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
Set OutlookMail = OutlookApp.CreateItem(0)
Dim yourPassword As String
Dim EDC As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFormatNum As Long


    
    yourPassword = "******"

   For Each sh In ActiveWorkbook.Worksheets
        sh.Unprotect Password:=yourPassword
Next sh
Set EDC = ThisWorkbook
TempFilePath = Environ$("temp") & ""
TempFileName = "EDC" & " " & Sheets("Welcome").Range("Q15").Value
FileExtStr = ".xlsm": FileFormatNum = 52
With EDC
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutlookMail
    .Display
    End With
    signature = OutlookMail.Body
    With OutlookMail
    .To = Sheets("Welcome").Range("R3").Value
    .CC = ""
    .BCC = ""
    .Subject = Sheets("Welcome").Range("R6").Value
    .HTMLBody = "<p style='font-family:calibri;font-size:14'>" & "Please find the attached checking template." & "</p>" & vbNewLine & signature
    .Attachments.Add EDC.FullName
    .Send
  End With
      
 
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutlookMail = Nothing
Set OutlookApp = Nothing

For Each sh In ActiveWorkbook.Worksheets
        sh.Protect Password:=yourPassword
    Next sh
    
    
 
           
    
End Sub

 

[sijpie]

I’ll look at it on Monday

 

[sijpie]

I have re-ordened your code a bit and added comments to make it easier to follow. Check out the last comment (with the <<<<). Is reprotecting the sheets really necessary, or are you going to close the workbok anyway without saving?

Option Explicit


Sub Bevel1_Click()
    Dim sh As Worksheet
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim signature As String
    Dim yourPassword As String
    Dim EDC As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFormatNum As Long
    Dim atA As Variant
    
    ' Set up the Outlook object (open outlook)
    #If  Win64 Then
        Set OutlookApp = GetObject(, "Outlook.Application")
    #Else 
        Set OutlookApp = CreateObject("Outlook.Application")
    #End  If
    Set OutlookMail = OutlookApp.CreateItem(0)




    
    yourPassword = "******"
    'Set up the workbook for sending, unprotect all the sheets
    Set EDC = ThisWorkbook
    For Each sh In EDC.Worksheets
        sh.Unprotect Password:=yourPassword
    Next sh
    
    ' Then store the workbook as a temporary file
    TempFilePath = Environ$("temp") & ""
    TempFileName = "EDC" & " " & Sheets("Welcome").Range("Q15").Value
    FileExtStr = ".xlsm": FileFormatNum = 52
    
    With EDC
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
    End With
    
    'Open the Outlookmail
    On Error Resume Next
    With OutlookMail
        .Display
    End With
    'and fill out the various fields and content
    signature = OutlookMail.Body
    With OutlookMail
        .To = Sheets("Welcome").Range("R3").Value
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Welcome").Range("R6").Value
        .HTMLBody = "" & "Please find the attached checking template." & _
            vbNewLine & signature
        ' Delete any image attachments from the signatures
        For Each atA In OutlookMail
            atA.Delete
        Next atA
        
        'Add the workbook
        .Attachments.Add EDC.FullName
        ' and send the email
        .Send
    End With
          
    ' Delete the temporary workbook
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    
    ' reprotect the worksheets (<<<< why? are you going to resave this workbook again under a new name?)
    For Each sh In ActiveWorkbook.Worksheets
            sh.Protect Password:=yourPassword
    Next sh
    
End Sub

 

[stevewood1]

Hello,

Thank you for your help. You're probably right. I don't think I need to re-protect the sheet as users open a new copy each time.

When I try and run your code I'm still getting the error message Compile error user defined type not defined and it's the line Dim atA as Varient that seems to be causing the issue.

Thanks

 

[sijpie]

On my PC it runs fine. I don't know how a variant declaration could result in a user defined type not defined error. I ddi notice that one of the string variables was not defined, so I added it.

Option Explicit


Sub Bevel1_Click()
    Dim sh As Worksheet
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim signature As String
    Dim yourPassword As String
    Dim EDC As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String, FileExtStr As String
    Dim FileFormatNum As Long
    Dim atA As Variant
    
    ' Set up the Outlook object (open outlook)
    #If  Win64 Then
        Set OutlookApp = GetObject(, "Outlook.Application")
    #Else 
        Set OutlookApp = CreateObject("Outlook.Application")
    #End  If
    Set OutlookMail = OutlookApp.CreateItem(0)




    
    yourPassword = "******"
    'Set up the workbook for sending, unprotect all the sheets
    Set EDC = ThisWorkbook
    For Each sh In EDC.Worksheets
        sh.Unprotect Password:=yourPassword
    Next sh
    
    ' Then store the workbook as a temporary file
    TempFilePath = Environ$("temp") & ""
    TempFileName = "EDC" & " " & Sheets("Welcome").Range("Q15").Value
    FileExtStr = ".xlsm": FileFormatNum = 52
    
    With EDC
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
    End With
    
    'Open the Outlookmail
    On Error Resume Next
    With OutlookMail
        .Display
    End With
    'and fill out the various fields and content
    signature = OutlookMail.Body
    With OutlookMail
        .To = Sheets("Welcome").Range("R3").Value
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Welcome").Range("R6").Value
        .HTMLBody = "" & "Please find the attached checking template." & _
            vbCrLf & vbCrLf & signature
        ' Delete any image attachments from the signatures
        For Each atA In OutlookMail
            atA.Delete
        Next atA
        
        'Add the workbook
        .Attachments.Add EDC.FullName
        ' and send the email
        .Send
    End With
          
    ' Delete the temporary workbook
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    
'    ' reprotect the worksheets (<<<< why? are you going to resave this workbook again under a new name?)
'    For Each sh In ActiveWorkbook.Worksheets
'            sh.Protect Password:=yourPassword
'    Next sh
    
End Sub

 

[sijpie]

Try stepping through the code:
In the VBA editor, click in the sub somewhere. Then press F8 key. Continue doing this. Each statement will be stepped through. Then you can see exactly where the error occurs.

Read my little guide for better programming for more tips on debugging. (link below in my tag line)