Damien Hartzell
New Member
- Joined
- Jun 6, 2024
- Messages
- 20
- Office Version
- 365
- Platform
- Windows
I have an .xlsm with VBA set to create an email in Outlook. Most users have success in using the button that initiates the macro, however for some users the macro spins and then does nothing. I've narrowed it down to the line Set OutMail = OutApp.CreateItem(0) in the following code. Any insight as to why this may work for some but not others would be most appreciated.
Here is the code:
Here is the code:
VBA Code:
Sub CreateEmailFromExcel()
On Error GoTo Err
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As MailItem
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Tenure = Range("H5").Text
Un = Range("H7").Text
weekend = Range("H3").Text
GracePeriod = Range("F3").Value
NewHireOccurrences = Range("C7").Value
NHCA1 = Range("B9").Text
NHWritten = Range("C9").Text
NHCA2 = Range("B10").Text
NHFinal = Range("C10").Text
TotalOccurrenceHours = Range("H10").Value
TenCA1 = Range("B15").Text
TenDocCoaching = Range("C15").Text
TenDocCoachingHoursSince = Range("F15").Value
TenCA2 = Range("B16").Text
TenWritten = Range("C16").Text
TenWrittenHoursSince = Range("F16").Value
TenCA3 = Range("B17").Text
TenFinal = Range("C17").Text
TenFinalHoursSince = Range("F17").Value
UnionOccurrences = Range("C20").Value
UnCA1 = Range("B22").Text
UnDocCoaching = Range("C22").Text
UnDocCoachingOccurrencesSince = Range("F22").Text
UnCA2 = Range("B23").Text
UnVerbal = Range("C23").Text
UnVerbalOccurrencesSince = Range("F23").Text
UnCA3 = Range("B24").Text
Un1stWritten = Range("C24").Text
Un1stWrittenOccurrencesSince = Range("F24").Text
UnCA4 = Range("B25").Text
Un2ndWritten = Range("C25").Text
Un2ndWrittenOccurrencesSince = Range("F25").Text
UnCA5 = Range("B26").Text
UnFinal = Range("C26").Text
UnFinalOccurrencesSince = Range("F26").Text
FMLAHours = Range("C29").Value
'add default signature; this will be listed in htmlbody as "OutMail.HTMLBody"
OutMail.Display
'Update Font and Size with this: <P STYLE='font-family:CalistoMT;font-size:16pt'>
With OutMail
If Tenure = "New Hire" Then
.To = ""
.Subject = "Your Unscheduled and/or FMLA Time"
.HTMLBody = "<P STYLE='font-family:CalistoMT;font-size:16pt'> Hello. <br><br>" & _
"Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
"You currently have " & NewHireOccurrences & " occurrence(s)." & vbNewLine & vbNewLine & _
"Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
"Reminders: a) The 40-hour grace period includes all unscheduled, paid Time Off Types (including FMLA), b) Total Occurrences includes unscheduled paid time exceeding that 40 hours, as well as Unpaid and Blackout time accrued, and c) any time that indicates Excused is not applying toward 40-hour grace period or to disciplinary action steps. <br><br>" & _
"Thank you! <br><br>" & _
RangetoHTML(rng) & "<br><br>" & _
OutMail.HTMLBody
.Display
ElseIf Un = "Yes" Then
.To = ""
.Subject = "Your Unscheduled and/or FMLA Time"
.HTMLBody = "<P STYLE='font-family:CalistoMT;font-size:16pt'> Hello. <br><br>" & _
"Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
"You currently have " & UnionOccurrences & " occurrence(s) of unscheduled time. <br><br>" & _
"Your FMLA usage for the past 12 months is currently " & FMLAHours & " hour(s). <br><br>" & _
"Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
"Thank you! <br><br>" & _
RangetoHTML(rng) & "<br><br>" & _
OutMail.HTMLBody
.Display
ElseIf Tenure = "Tenure" Then
.To = ""
.Subject = "Your Unscheduled and/or FMLA Time"
.HTMLBody = "<P STYLE='font-family:CalistoMT;font-size:16pt'> Hello. <br><br>" & _
"Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
"You have accrued " & GracePeriod & " hour(s) toward your 40-hour grace period. You currently have " & TotalOccurrenceHours & " Total Occurrence Hour(s), which is the sum of Unpaid, Blackout Period and Unscheduled Paid Time beyond the 40-hour grace period. <br><br>" & _
"Your FMLA usage for the past 12 months is currently " & FMLAHours & " hour(s). <br><br>" & _
"Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
"Reminders: a) The 40-hour grace period includes all unscheduled, paid Time Off Types (including FMLA), b) Total Occurrence Hours includes unscheduled paid time exceeding that 40 hours, as well as Unpaid and Blackout time accrued, and c) any time that indicates Excused is not applying toward 40-hour grace period or to disciplinary action steps. <br><br>" & _
"Thank you! <br><br>" & _
RangetoHTML(rng) & "<br><br>" & _
OutMail.HTMLBody
.Display
End If
End With
Set OutMail = Nothing
Err:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.EnableEvents = True
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Dim ActiveTable As String
Range("H15").Select
ActiveTable = ActiveCell.ListObject.Name
With Range(ActiveTable).ListObject
''
Range("H15:M15").Select
Range(Selection, Selection.End(xlDown)).Select
''
Selection.Copy
End With
'
Set Cell = Nothing
'Copy the range and create a new workbook to paste the data in
'''rng.Copy
On Error GoTo Err
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
'.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
'autofit columns to text:
Columns("A:F").AutoFit
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'''''''''''''''''''''''
'''''''''''''''''
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
Err:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.EnableEvents = True
End Function
