Excel VBA to insert cell data into outlook email

S

skutchinski

New member
Joined
Apr 29, 2014
Messages
3
Reaction score
0
Points
0
I've created a log that tracks our office library resources. When a checked out book becomes overdue, I've added code that automates sending an email to the person who checked out the resource notifying them of the overdue book. The code below works beautifully and i'm able to successfully generate the email and send, but only with the .body set to specific text. I would like to also add a carriage return and insert the title of the book that is past due. Below is the code I'm struggling with.

Code: 
[SIZE=1][I]Private Sub Worksheet_Change(ByVal Target As Range)
If Range("H3").Value = "OVERDUE" Then
 sendBook (Range("I3").Text)

End If
 End Sub[/I][/SIZE]

And:

Code: 
[SIZE=1][I]Sub sendBook(theAddy As String)
 
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Dim wb As Workbook, wasOpen As Boolean
 On Error Resume Next
 wasOpen = True
 Workbooks(Sheet1).Activate
 If Err <> 0 Then
 Set wb = Workbooks.Open("C:\Users\op936sp\Documents\ADMIN\Library\Library Check In-Check Out.xlsx")
 wasOpen = False
 Err.Clear
 Else
 Set wb = ActiveWorkbook
 wb.Save
 End If
 Dim olApp As Object, olMsg As Object
 Set olApp = CreateObject("Outlook.Application")
 Set olMsg = olApp.CreateItem(0)
 With olMsg
 .To = theAddy
 .cc = (my email address)
  .Subject = "Overdue Library Book Alert"
 .Body = "Please return the overdue resource listed below to MS 56.  If you would like to request an extension, please contact Stephanie Kutchinski at ext. 4686." [SIZE=1][COLOR=#ff0000][B](Here is where is want to insert a carriage return and include the library book title found in column A) 
[/B][/COLOR][/SIZE] .Send
 End With
 If wasOpen = False Then
 wb.Close True
 End If
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Set olApp = Nothing
 Set olMsg = Nothing
 End Sub[/I][/SIZE]
Any help would be much appreciated!
 
Last edited by a moderator:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("H3").Value = "OVERDUE" Then
    
        Call sendBook(Range("I3").Text, Range("A1").Text)
    End If
End Sub



Sub sendBook(ByVal theAddy As String, ByVal theBook As String)
Dim wb As Workbook, wasOpen As Boolean
Dim olApp As Object, olMsg As Object
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error Resume Next
    wasOpen = True
    Workbooks(Sheet1).Activate
    If Err <> 0 Then
    
        Set wb = Workbooks.Open("C:\Users\op936sp\Documents\ADMIN\Library\Library Check In-Check Out.xlsx")
        wasOpen = False
        Err.Clear
    Else
    
        Set wb = ActiveWorkbook
        wb.Save
    End If
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0)
    With olMsg
    
        .To = theAddy
        .cc = (my email address)
        .Subject = "Overdue Library Book Alert"
        .Body = "Please return the overdue resource listed below to MS 56. " & _
                "If you would like to request an extension, please contact Stephanie Kutchinski at ext. 4686." & vbNewLine & _
                theBook
        (Here is where is want to insert a carriage return and include the library book title found in column A)
        .Send
    End With
    
    If wasOpen = False Then
        
        wb.Close True
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Set olApp = Nothing
    Set olMsg = Nothing
End Sub
 
Thanks for the quick reply! I made some minor tweeks and this worked great until I realized my original code and approach did not function properly after all.
I discovered that when the library resource listed in column A became "OVERDUE" (shown in column H), multiple errors were occurring:

1. Worksheet change event was triggered by ANY change and would send multiple emails for every instance of "OVERDUE", including those which had already received an overdue notice.
2. All emails referenced the book details found in row 2 only.
3. No emails were triggered if row 2 (the first row of range) was NOT overdue.

It looks like I need an entirely new code to accomplish what I need. Right now, the worksheet acccomplishes the following:

-When someone checks out a title found in column "A", the date is entered into column "F" of the relevant row and their email addy into column "I"
-Then cell formulas in column "G" populate its cell automatically with the due date for two weeks later.
-If the date in column "G" becomes past due, cell formulas in column "H" then populate its cells with "OVERDUE"

At this point, what I was trying to accomplish was the automatice generation of an email to the borrower when their book becaume overdue. Below is what I have thus far. It's your coding from above with some minor changes. Any guidance as to how to tackle this project would be wonderful! If you need additional info or the worksheet itself to view I'm happy to send.

CODE

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("H2").Value = "OVERDUE" Then
Call sendBook(Range("I2").Text, Range("A2").Text, Range("E2").Text)


End If
End Sub
Click to expand...

CODE

Sub sendBook(ByVal theAddy As String, ByVal theBook As String, ByVal theType As String)
Dim wb As Workbook, wasOpen As Boolean
Dim olApp As Object, olMsg As Object

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
wasOpen = True
Workbooks(Sheet1).Activate
If Err <> 0 Then

Set wb = Workbooks.Open("C:\Users\op936sp\Documents\ADMIN\Library\Library Check In-Check Out.xlsx")
wasOpen = False
Err.Clear
Else

Set wb = ActiveWorkbook
wb.Save
End If

Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)
With olMsg

.To = theAddy
.Subject = "Overdue library " & theType & " notice"
.HTMLbody = "Please return the overdue " & theType & " listed below to MS 56. If you would like to request an extension, please contact Stephanie Kutchinski at ext. 4686." & "<P><B><I>" & theBook & "</P></B></I>"
.Send
End With
If wasOpen = False Then
wb.Close True
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Set olApp = Nothing
Set olMsg = Nothing
End Sub
Click to expand...
 
I am afraid I do not understand what the problem is. I know what you are saying is wrong, but I do not see how that is happening.
 
Bob Phillips said:
I am afraid I do not understand what the problem is. I know what you are saying is wrong, but I do not see how that is happening.
Click to expand...

When I initially tested the document, I didn't quite get what the problem was either becuase I was only using my email address. After changing that method and using multiple addresses throughout the document I was finally able to determine that the only emails being sent were to the first record only in H2. If it helps make sense, I've attached a pared down version of my spreadsheet here for review. The original contains 700+ titles that I track and was too large to attach.
View attachment Library Log - MASTER Test.xlsm
 
You must log in or register to reply here.
Back
Top