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