Public Function createEmail(row As Long)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim newWS As Worksheet
Dim ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim fRow As Integer
Dim lRow As Integer
Dim i, j As Integer
Dim BodyTxt As String
Dim SendTo As String
Dim OutApp As Object
Dim NewMail As Object
Dim writeA As Boolean
Dim Answer As Integer
Dim cReq As Variant
Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject
ThisWorkbook.Unprotect ""
Set wb1 = ThisWorkbook
If row = 1 Then
Set ws = ThisWorkbook.Worksheets("Positions")
ElseIf row = 2 Then
Set ws = ThisWorkbook.Worksheets("Updates Needed")
End If
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
fRow = FirstInst 'FirstInst and LastInst are global variables
lRow = LastInst
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Make a copy of the file.
' If you want to change the file name then change only TempFileName variable.
TempFilePath = Environ$("temp") & "\"
If row = 1 Then
TempFileName = UserInst & " Update" 'UserInst is a global variable
Else
TempFileName = "Updates Required"
End If
FileExtStr = ".xlsx"
Set wb2 = Workbooks.Add
wb2.SaveAs TempFilePath & TempFileName & FileExtStr
If row = 1 Then
ws.Rows(1).EntireRow.Copy
wb2.Worksheets("Sheet1").Range("A1").Select
wb2.Worksheets("Sheet1").Paste
wb2.Worksheets("Sheet1").Name = TempFileName
j = 2
For i = fRow To lRow
ws.Rows(i).EntireRow.Copy
wb2.Worksheets(TempFileName).Rows(j).Select
wb2.Worksheets(TempFileName).Paste
j = j + 1
Next i
'ws.Cells(1, 1).Select
wb2.Worksheets(TempFileName).Cells(1, 1).Select
BodyTxt = "Attention Staff," & vbNewLine & vbNewLine & _
"Please be advised that this is an automated message created by one of your staff members using the Automated Library Contact List Update Program." & vbNewLine & vbNewLine & _
UserName & " has submitted the attached report. Please retain this information." & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & vbNewLine & "Library Report Bot"
ElseIf row = 2 Then
ws.Activate
ws.Range("A1", "L174").Select
Selection.Copy
Set newWS = wb2.Worksheets("Sheet1")
newWS.Activate
newWS.Cells.Select
newWS.Paste
newWS.Cells(1, 1).Select
BodyTxt = "Attention Staff," & vbNewLine & vbNewLine & _
"Please be advised that this is an automated message created by one of your staff members using the Automated Library Contact List Update Program." & vbNewLine & vbNewLine & _
"The following sheet contains a list of users whose contact list has not been updated during this quarter." & _
" You may wish to reach out the Senior Librarian at each institution to update their respective contacts." & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & vbNewLine & "Library Report Bot"
End If
clipboard.Clear
Application.CutCopyMode = False
wb2.Application.CutCopyMode = False
SendTo = ""
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set NewMail = OutApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = SendTo
.CC = ""
.BCC = ""
.Subject = UserInst & " Contact List Update " & Format(Now, "dd-mmm-yy h-mm-ss")
.Body = BodyTxt
.Attachments.Add wb2.FullName
.Display
End With
wb2.Close savechanges:=False
On Error GoTo 0
MsgBox "The program completed this task successfully."
Kill TempFilePath & TempFileName & FileExtStr
Set NewMail = Nothing
Set otlApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ExitSub:
End Function
