Send email w/Command Button and attach just the active sheet

0

Hello, I have my command button to pretty much do exactly what I need it to except the attachment it populates is blank and not the current (active sheet) the button is in on the workbook. For backgroud, it is a work book that has the entire unit's IT inventory on it. It has sheets broken out into sections. In those sections are specific inventory accounts. On one specific sheet ("sheet8 (FSC-U006)") which is just that one account's inventory, I have placed a command button that will auto populate an email to the selected email addresses with a reminder to validate their current annual inventory. It automatically saves a new workbook on my desktop with the same name of the sheet and also attaches that workbook to the email, BUT when you open the attachment or file on desktop, it is blank and not the contents of the active sheet.

Also, to go a little more detailed, I prefer to ensure the Active Sheet attachment contents are locked except the notes column (J) and the digital signature information column (K). In order for the POCs to not be able to alter their inventory for malicious reasons. I know how to protect it with a password, but I just want to ensure the attachement will also be protected. If that is too complicated or not possible it's ok!  

I basically merged 2 codes to get this far but am still an amateur. Any help would be great! Thank you!

Private Sub CommandButton1_Click()
    Dim rng As Range
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    
    Set rng = Nothing
    On Error Resume Next        'hiding the crash won't prevent it
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
                vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Dim newBook As Workbook, wFile As String
    wFile = ThisWorkbook.Path & "\FSC-U006.xlsx"
    Set newBook = Workbooks.Add
    newBook.SaveAs wFile
    newBook.Close False
      
' OnErrorResumeNext ' Hiding the crash won't prevent it
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hello Sir/Ma'am," & vbNewLine & vbNewLine & _
                "You are receiving this email because your Annual ITEC Inventory is Due. Please see attached and validate the items listed for your account. If there are changes to be made i.e. DRMO, ROS, New items to be added, please annotate that in the Notes Column. Then have the primary and alternate digitally sign the inventory and return back to me." & vbNewLine & vbNewLine & _
                "If you have any questions please don't hesitate to contact me." & vbNewLine & vbNewLine & _
                "Thank you"
    
' On Error Resume Next ' hiding the crash won't prevent it
    With xOutMail
        .To = Recipients(Selection)
        .CC = ""
        .BCC = ""
        .Subject = "Annual ITEC Inventory Due"
        .Attachments.Add wFile
        .Body = xMailBody
        .Display 'or use .Send
    End With
    
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub
Private Function Recipients(SelRng As Range) As String
    ' 25 Sep 2019
    Dim Fun As String
    Dim Cell As Range
    Dim Tmp As String
    On Error Resume Next        ' return a blank string if nothing was selected
    For Each Cell In SelRng.Columns(1).SpecialCells(xlCellTypeVisible)
        Tmp = Cell.Value
        ' test if the cell appears to contain an email address
        If InStr(Tmp, "@") Then
            If Len(Fun) Then Fun = Fun & ";"
            Fun = Fun & Tmp
        End If
    Next Cell
    Recipients = Fun
End Function
 
Answer
Discuss

Answers

1

I have commented your code to show why it produces a blank workbook. I then added code to create a workbook from the ActiveSheet and save it to the Desktop under the name you have specified. It seems that your existing code will then attach that workbook to the email it also creates.

Option Explicit

Private Sub CommandButton1_Click()
    Dim Rng As Range
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim wFile As String

    Set rng = Nothing
    On Error Resume Next        'hiding the crash won't prevent it
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
                vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    ' this will be the Desktop only if the workbook containing this code
    ' is on the Desktop
'    wFile = ThisWorkbook.Path & "\FSC-U006.xlsx"
'   The next line will set the path to the Desktop regardless
    wFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\FSC-U006.xlsx"

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


'    Set newBook = Workbooks.Add             ' this creates a new blank workbook
'    newBook.SaveAs wFile                    ' and saves it as wFile
'    newBook.Close False                     ' no wonder it's blank

    ActiveSheet.Copy                         ' create a new workbook from the ActiveSheet
    With ActiveWorkbook
        .SaveAs wFile
        .Close
    End With

    ' you have to re-enable screen updating and events at some time
    ' why not now and here?
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

' OnErrorResumeNext ' Hiding the crash won't prevent it
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hello Sir/Ma'am," & vbNewLine & vbNewLine & _
                "You are receiving this email because your Annual ITEC Inventory is Due. Please see attached and validate the items listed for your account. If there are changes to be made i.e. DRMO, ROS, New items to be added, please annotate that in the Notes Column. Then have the primary and alternate digitally sign the inventory and return back to me." & vbNewLine & vbNewLine & _
                "If you have any questions please don't hesitate to contact me." & vbNewLine & vbNewLine & _
                "Thank you"

' On Error Resume Next ' hiding the crash won't prevent it
    With xOutMail
        .To = Recipients(Selection)
        .CC = ""
        .BCC = ""
        .Subject = "Annual ITEC Inventory Due"
        .Attachments.Add wFile
        .Body = xMailBody
        .Display 'or use .Send
    End With

    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Private Function Recipients(SelRng As Range) As String
    ' 25 Sep 2019
    Dim Fun As String
    Dim Cell As Range
    Dim Tmp As String
    On Error Resume Next        ' return a blank string if nothing was selected
    For Each Cell In SelRng.Columns(1).SpecialCells(xlCellTypeVisible)
        Tmp = Cell.Value
        ' test if the cell appears to contain an email address
        If InStr(Tmp, "@") Then
            If Len(Fun) Then Fun = Fun & ";"
            Fun = Fun & Tmp
        End If
    Next Cell
    Recipients = Fun
End Function

Edit 28 Sep 2019  =======================================

Referring to your comment, if you specify the fileformat Excel won't ask you which format to use. That would look like this (instead of the above). The specified file format will cause an xlsx extension.

    With ActiveWorkbook
        .SaveAs wFile, xlOpenXMLWorkbook
        .Close
    End With

BTW, you can modify the file either before you save it or after, such as locking cells and applying protetion. Before the SaveAs command the workbook has no name. Some actions which require it to have been saved will not be available. If you run against such a problem, perhaps when applying protection, make the changes after saving the file and close it with .Close True.

Discuss

Discussion

Hello Variatus! Thank you for the help again! So when I copied the code and then went to run it, I get a pop up that says: " The following features cannot be saved in macro-free workbooks:
*VB project
To save a file with these features, click No, and then choose a macro-enabaled file type in the File Type List.
To continue saving as a macro-free workbook, click Yes"

Now when I click yes, it exucutes exactly as needed, saved a copy on my desktop and populates the email with the attached active sheet only (Perfect). I do not want it to be macro enabled because it would then allow the POCs to use the Command button that shows on the attachment and I do not want that. I would perfer it to be useless, which it is with the current setup by clicking Yes. My only question, is there a way to bypass that pop up window and have the active sheet workbook be automatically saved in that format? This inventory tracker will be utilized by more than just me, and I do not want anyone to become confused and click No-which opens the debugger on the "new activesheet workbook" to try and fix the saving file format issue. I hope that made sense and was not confusing.
Tori M (rep: 2) Sep 27, '19 at 9:23 am
I have appended a solution to my answer. It isn't tested. Read up on the SaveAs method to learn more about the possibilities on offer.
Variatus (rep: 4068) Sep 28, '19 at 3:47 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login