I have an Excel spreadsheet which contains information about equipment on loan: name, email address, description, hyperlink to the loan document, date of loan, etc.
I have VBA code which runs through the sheet, checking for loan date, and if the return date is within 7 days of return, automatically emails the 'loanee' with the details pulled from the sheet.
Once an email is sent, it then updates the sheet with details of when the email was sent. All is working, apart from the hyperlink to their document.
All I get is the text from the cell.
Private Sub Workbook_Open()
Worksheets("Tracker").Select
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendCC As String
Dim sSubject As String
Dim sTemp As String
Dim strBody As String
Dim Sigstring As String
Dim Signature As String
Dim sURL As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
sSendCC = Range("D3").Value
sSubject = "You are within 7 days of the deadline"
Sigstring = Environ("appdata") & _
"\Microsoft\Signatures\Mike.htm"
If Dir(Sigstring) <> "" Then
Signature = GetBoiler(Sigstring)
Else
Signature = ""
End If
lLastRow = Cells(Rows.Count, 5).End(xlUp).Row
For lRow = 7 To lLastRow
sURL = Cells(lRow, 5).Value
If Not IsEmpty(Cells(lRow, 3)) Then
If Cells(lRow, 8) <> "YES" Then
If Cells(lRow, 7) <= Now() + 7 Then
Set OutMail = OutApp.CreateItem(0)
strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
"You have previously signed the loan of equipment from my department." & "<br><br>" & _
"You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
"Description of loan: " & Cells(lRow, 4).Value & "<br><br>" & _
"Hyperlink: " & Cells(lRow, 5) & "<br><br>" & _
"Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"
With OutMail
.Display
End With
On Error Resume Next
With OutMail
.To = Cells(lRow, 3)
If sSendCC > "" Then .CC = sSendCC
.Subject = sSubject
.HTMLBody = "<html><body>" & strBody & Signature
SendKeys ("^{ENTER}")
End With
Set OutMail = Nothing
Cells(lRow, 8) = "YES"
Cells(lRow, 9) = "E-mail sent on: " & Now()
End If
End If
End If
Next lRow
Set OutApp = Nothing
End Sub
You need to add a [Some_Hyperlink_Text] tag in your code.
try this modified bit of your code
sURL = Cells(lRow),5).Hyperlinks(1).Address
strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
"You have previously signed the loan of equipment from my department." & "<br><br>" & _
"You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
"Description of loan: " & Cells(lRow, 4).Value & "<br><br>" & _
"Hyperlink: 'Insert Hyperlink Text Here'<br><br>" & _
"Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"
In the above code that I have modified, I am assuming that Cells(lRow, 5).value (sURL variable) is a URL (not a in worksheet hyperlink). If it is a worksheet hyperlink, then you might need to extract the link.
Related
Hello Everyone i was wondering if anyone can help me resolve my problem., i have got code which i found from the net which is working absolutely perfect however only problem is that when there is more than one due date in the column it will send email each time instead of sending all due date and names in One email at same time. Names it is on column A, Expiry Date it is in column E, and email stamp as sent in Column F, below its the code.
Private Sub Workbook_Open()
Dim Email As String, Subj As String, Msg As String, wBox As String
Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
Set wsEmail = ThisWorkbook.Sheets("Tracker")
Set dic = CreateObject("scripting.dictionary")
With wsEmail
For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(RowNo, "E") <> "" Then
If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
If dic.exists(.Cells(RowNo, "F").Value) Then
dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
Else
dic(.Cells(RowNo, "A").Value) = RowNo & "|"
End If
End If
End If
Next
For Each ky In dic.keys
cad = Left(dic(ky), Len(dic(ky)) - 1)
cad = Split(cad, "|")
wBox = ""
dBox = ""
For i = 0 To UBound(cad)
wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
dBox = wsEmail.Cells(cad(i), "E")
.Cells(cad(i), "F") = "Sent"
.Cells(cad(i), "G") = Environ("username")
.Cells(cad(i), "H") = "E-mail sent on: " & Now()
Next
On Error Resume Next
Set OutApp = GetObject("Outlook.Application")
On Error GoTo 0
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Do: Loop Until Not OutApp Is Nothing
Set OutMail = OutApp.CreateItem(0)
With OutMail
Subj = wBox & Space(1) & "from will expire soon"
Msg = "Hi" & vbCrLf & vbCrLf _
& "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
& "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
& vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = Subj
.ReadReceiptRequested = False
.Body = Msg
.Display
End With
mystring = ("Email has been sent for below staff;") & _
vbCrLf & vbCrLf & ky
MsgBox mystring
Set OutApp = Nothing
Set OutMail = Nothing
Next
End With
End Sub
is there any way to do this?
This should get you started.
Read the code's comments and adjust it to fit your needs.
Private Sub SendEmails()
Dim trackerSheet As Worksheet
Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
Dim lastRow As Long
lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
Dim trackerRange As Range
Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
' Declare boolean to check if there are any expiring names
Dim anyExpiring As Boolean
Dim nameCell As Range
For Each nameCell In trackerRange
' Check: 1) There is a expiring date
' 2) Email not sent yet
' 3) Expiring date less than today + 60 días
If nameCell.Offset(0, 4).Value <> "" And _
nameCell.Offset(0, 5).Value = "" And _
nameCell.Offset(0, 4).Value <= Date + 60 Then
' Store names and expiring dates into array
Dim infoArray() As Variant
Dim counter As Long
ReDim Preserve infoArray(counter)
infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
counter = counter + 1
' Stamp action log
nameCell.Offset(0, 5).Value = "Sent"
nameCell.Offset(0, 6).Value = Environ$("username")
nameCell.Offset(0, 7).Value = "E-mail sent on: " & Now()
' To be able to check later
anyExpiring = True
End If
Next nameCell
' Exit if there are not expiring contacts
If Not anyExpiring Then
MsgBox "There are not expiring contacts"
Exit Sub
End If
' Prepare message
Dim namesList As String
For counter = 0 To UBound(infoArray)
namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
Next counter
Dim emailBodyTemplate As String
emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
"Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
"<namesList>" & vbCrLf & vbCrLf & _
"Many Thanks " & vbCrLf & _
vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
Dim emailBody As String
emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
' Start outlook (late bound)
Dim outApp As Object
On Error Resume Next
Set outApp = GetObject("Outlook.Applicatin")
On Error GoTo 0
' If outlook is not running, start an instance
If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
Do: Loop Until Not outApp Is Nothing
' Compose email
Dim outMail As Object
Set outMail = outApp.CreateItem(0)
With outMail
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = "CTC will expire soon"
.ReadReceiptRequested = False
.Body = emailBody
.Display
End With
' Display message to user
Dim staffMessage As String
staffMessage = ("Email has been sent for below staff")
MsgBox staffMessage
' Clean up
Set outApp = Nothing
Set outMail = Nothing
End Sub
Let me know if it works
I have a vba code which generates a outlook email, populates with required To, CC, Subject and Body when i change a particular column in excel. And when the email is sent my status column updates to 'Closed' and Email Sent Flag column updates to '1'.
But the problem is when i click on close instes on Send on my email( which was generated and auto populated) even then my status and Email sent flag column gets updated with Closed and 1 respectively. Below is my code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
Dim html As String
Dim intR As String
Dim ccStr As String
Dim Signature As String
Dim html1 As String
'Dim itmevt As New CMailItemEvents
'Dim tsp As String
lRow = Cells(Rows.Count, 17).End(xlUp).Row
lRow1 = ThisWorkbook.Sheets("Validation Lists").Cells(Rows.Count, 4).End(xlUp).Row
html = "<br>" & ("Hi,") & ("Please spare some time to provide feedback for our service. This will help us to serve you better for upcoming services.") & "<br>"
For i = 2 To lRow1
ccStr = ";" & ThisWorkbook.Sheets("Validation Lists").Cells(i, "D").Value & ccStr
Next i
For i = 1 To lRow
If (Cells(i, "Q").Value = "Closed") And (Cells(i, "R").Value <> "1") Then
intR = MsgBox("Do you want to send a feedback for " & Cells(i, "B") & "Viz." & Cells(i, "C").Value & " to " & Cells(i, "C") & "?", vbQuestion + vbYesNo)
If intR = vbYes Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.To = Cells(i, "I").Value
.CC = ccStr
.display
Signature = .HTMLBody
.Subject = "Feedback for " & Cells(i, "B").Value & " viz. " & Cells(i, "C").Value
.HTMLBody = html & "This request was assited by " & Cells(i, "K").Value & "<br><br>" & Signature
'.dispaly
'.Send
End With
Cells(i, "R").Value = "1"
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
On Error Resume Next
End If
If intR = vbNo Then Cells(i, "Q").Value = "In Progress"
End If
Next i
End Sub
You have to check if the message has been sent.
There exists a boolean message property named Sent.
Untested but could work:
Loop until .Sent is True.
With xMailItem
.To = Cells(i, "I").Value
.CC = ccStr
.display
Signature = .HTMLBody
.Subject = "Feedback for " & Cells(i, "B").Value & " viz. " & Cells(i, "C").Value
.HTMLBody = html & "This request was assited by " & Cells(i, "K").Value & "<br><br>" & Signature
Do Until .Sent = True
DoEvents
Loop
End With
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
I need to modify an existing macro by which I can perform the following functions:
Should have the option to enter the number of rows required to draft the email/s.
The Macro should include the last row plus the number of rows entered
(eg. I enter "5" that would mean Last row + 4 rows above it).
Individual email should be drafted for each row.
(eg. Last row would be Mailto = Colleague3#hotmail.com ; MailSubject = "EmailSubject_As_Per_the_Cell" Mailbody = "Hi Friend3, I’m inviting you for the conference being held today."
Other details are should be retained as is. (eg. Signatures etc.)
NOTE: My Excel sheet has 6-7 Columns which contains all the Project no./meeting no./Presenter Name/ Atendees name etc.
I tried tweaking with the VBA code but I'm not able to get through it.
Sub Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object, signature As String
Dim irow As Integer
Dim objItem As Object
irow = InputBox("How many Invites do you want to send?")
LastRow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
If Cells(LastRow, 1).Value <> "" Then
Mailto = Cells(LastRow, 1).Offset(0, 5).Value
If Mailto = "Colleague1" Then Mailto = "Colleague1#hotmail.com"
If Mailto = " Colleague2" Then Mailto = " Colleague2#hotmail.com"
If Mailto = " Colleague3" Then Mailto = " Colleague3#hotmail.com"
End If
MailSubject = Cells(LastRow + irow, 1).Offset(0, 4).Value & " – Important Message"
MailBody = "Hi " & Cells(LastRow, 1).Offset(0, 5).Value & "," & vbNewLine & vbNewLine & _
" I’m inviting you for the conference being held today." & _
vbNewLine
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Display
End With
signature = OutMail.body
With OutMail
.Subject = MailSubject
.To = Mailto
.body = MailBody & vbNewLine & signature
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I'm presupposing you have the Outlook stuff handled correctly... this looks like it's not actually sending any emails, just creating emails that are ready to be sent?
See if these changes bring you any closer to what you seek. This code is lightly tested but are by no means bulletproof.
Sub Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object, signature As String
Dim irow, i As Integer
Dim objItem As Object
irow = InputBox("How many Invites do you want to send?")
Set OutApp = CreateObject("Outlook.Application")
LastRow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
For i = 0 To irow - 1
Set OutMail = OutApp.CreateItem(o)
If Cells(LastRow - i, 1).Value <> "" Then
Mailto = Cells(LastRow - i, 5).Value
If Mailto = "Colleague1" Or _
Mailto = " Colleague2" Or _
Mailto = " Colleague3" Then
Mailto = Mailto & "#hotmail.com"
End If
End If
MailSubject = Cells(LastRow - i, 4).Value & " – Important Message"
MailBody = "Hi " & Cells(LastRow - i, 5).Value & "," & vbNewLine & vbNewLine & _
" I’m inviting you for the conference being held today." & _
vbNewLine
With OutMail
.Display
signature = .body
.Subject = MailSubject
.To = Mailto
.body = MailBody & vbNewLine & signature
End With
Next i
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I have a slight issue with a macro. It works fine at the moment, but I need to add some code to do the following but don't know at what point to add it:
If for each cell in Column C that there is a blank cell to look for the email address on the same row but 10 columns over to the right in Column M
In the start of the body "Hi There (Column B content)
In the body of the email I would like for the macro to insert the contents from column F like this: "Please choose the following option (Column F content)
Any Ideas on how I can modify the code to include these options please.
Thank you for your time.
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
For Each cel In Range(("C2"), Range("C2").End(xlDown))
strbody = "Hi there" & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutMail
.To = cel.Value
.CC = cel.Offset(0, 10).Value
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this one:
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
Else
.To = cel.Offset(0, 10).Value & ", " & Join(Application.Index(cel.Offset(, -2).Resize(, 4).Value, 0), ", ")
End If
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutApp = Nothing
End Sub