troyh68
New Member
- Joined
- Nov 14, 2016
- Messages
- 24
Back story - Our Safety team has an Incident Report that is to be used by all Supervisors and Leads for anyone that has gotten hurt. To make this easier and to make sure that everyone gets the information I have created a macro to do a few things.
1. Save a copy of the Incident Report as an .xlsx file to a specific directory that the file name is created from a cell range in the spreadsheet.
2. Create the Email to be sent to all of the people that need to get a copy of these. The Subject line will have the Persons name that was injured as well as the Incident date.
3. Close the workbook
I have changed this multiple times trying to get this correct so any help is VERY appreciated.
Current Code
1. Save a copy of the Incident Report as an .xlsx file to a specific directory that the file name is created from a cell range in the spreadsheet.
2. Create the Email to be sent to all of the people that need to get a copy of these. The Subject line will have the Persons name that was injured as well as the Incident date.
3. Close the workbook
I have changed this multiple times trying to get this correct so any help is VERY appreciated.
Current Code
VBA Code:
Sub IncidentReport()
'Save to File Destination
'Dim Path As String
'Dim Filename1 As String
'Application.DisplayAlerts = False
'Path = "C:\Users\t.harkness\Desktop\" '"\\network.local\dfs\Server\UserData\SAFETY\Incident Reports\"
'Filename1 = Range("AH2").Value & ".xlsx"
'ActiveWorkbook.SaveAs Path & Filename1, xlOpenXMLWorkbook
'Application.DisplayAlerts = True
'Troys Code From here to Send out Email
Dim FileName As String
Dim Path As String
Application.DisplayAlerts = False
'Path = "\\network.local\dfs\Server\UserData\SAFETY\Incident Reports\TEST Folder\"
FileName = Range("AH2").Value & ".xlsx"
ActiveWorkbook.SaveAs FileName:= _
"Z:\SAFETY\Incident Reports\" & FileName, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
'Send out Email
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "InjuryReport@millerbaking.com"
.CC = ""
.BCC = ""
.Subject = "Incident Investigation Report" & " " & Range("H15").Value & " " & Range("F9").Value
.Body = "Attached is an incident investigation report."
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Close workbook without saving
Application.DisplayAlerts = False
Application.Quit
End Sub