I would like to insert a link inside the body of the e-mail I am creating through excel VBA. The link changes every day so I have put its value in cells B4. However, I do not find a proper way to send the e-mail with that link.
This is the code I am using :
Public Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B5000").End(xlUp).Row
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Link = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown | " & Project_number & " " & Project_name & " | Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & Chr(10) & "Please enter your forecast at this link below." & Chr(10) & Chr(10) & Link & Chr(10) & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
There are only two possibilities IMHO:
the plain text Email: NO clickable link is possible
the HTML Email: clickable link is possible, well-formed HTML WITH <body> Tag is necessary!
Related
Im using below vba query to generate emails with attachment. However, i do not want the query to generate the details in attachments. Instead, i want the data to be paste in body of the email. Im not sure how to amend it. Please help
Sub Buyer_HU()
Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
Dim correo As String, lr As Long, wFile As String
Dim tempData As String '<== Changes here
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Sheets("Template")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("BA:BA").ClearContents
For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
Next
Set dict = CreateObject("scripting.dictionary")
For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
dict.Item(c.Value) = sh.Range("M" & c.Row)
Next
For Each Ky In dict.Keys
correo = dict(Ky)
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
Workbooks.Add
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
Dim wcc
wcc = Range("AY1")
Range("BA:BA").ClearContents
Range("BA:BA").ClearContents
Range("AY:AY").ClearContents
Range("M:M").ClearContents
Cells.Select
Selection.Columns.AutoFit
Range("A2").Select
tempData = ActiveSheet.Range("A2").Value '<== Changes here
wFile = ThisWorkbook.Path & "\Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData & ".xlsx" '<== Changes here
ActiveWorkbook.SaveAs wFile
ActiveWorkbook.Close False
Set dam = CreateObject("Outlook.Application").CreateItem(0)
With dam
.SentOnBehalfOfName = wcc
'.Bodyformat = olFormatHTML
.To = correo
.cc = ""
.Subject = "Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData '<== Changes here
.HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "06/12/2030 - means shipped and orders can be invoiced off" & "<br>" & "05/12/2030 - means order not received - please resend" & "<br>" & "04/12/2030 - means order cancelled - please cancel off at your end if not already done" & "<br>" & "03/12/2030 - means delivery date not known" & "<br>" & "02/12/2030 - means held, more info required" & "<br>" & "01/12/2030 - means held, price problem" & "<br>" & "<br>" & "All other dates should be ETA?dates (If promise date is unchanged please leave blank)" & "<br>" & "<br>" & "PLEASE REPLY IN FORMAT SENT" & "<br>" & "<br>" & "Backorder Report - Please Return by 12pm." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Currys B2B Planning Team"
.Attachments.Add wFile
.Display 'use .Send to send
End With
Next Ky
'sh.ShowAllData
'Selection.AutoFilter
Columns("BA:BA").Select
Selection.Delete Shift:=xlToLeft
MsgBox "Emails generated"
Range("A2").Select
End Sub
I am using the code below which is basically taken a screenshot of an userform and paste it in an outlook application. The macro is working fine.
What I am trying to achieve is to put an email introduction and then after paste the screenshot, but I am not able to do it properly because the screenshot is not being put after the text.
This is my code
Sub Screenshotemail()
Dim doc As Object, rng As Range
Application.SendKeys "(%{1068})"
DoEvents
'ActiveSheet.Paste
With CreateObject("Outlook.Application").CreateItem(0)
Set doc = .GetInspector.WordEditor
doc.Range(0, 0).Paste
.display
.To = ""
.CC = ""
.Body = "Dear All, " & Chr(10) & Chr(10) & "I kindly remind you that forecasts for program " & Chr(10) & Chr(10) _
& "Please enter your forecast at the link below." _
& Chr(10) & Chr(10) & lien & Chr(10) & Chr(10) & "Best Regards,"
.Subject = "Test:"
.Importance = olImportanceHigh
End With
End Sub
Is there a way to make it work?
My friend, It take me a few hours but i guess it works
just use, htmlbody instead body, and concat the htmlbody after your messagge
reference
Write before paste table in Outlook - Excel VBA
Sub Screenshotemail()
Dim doc As Object, rng As Range
Dim wdDoc As Object
Dim wdRange As Range
Application.SendKeys "(%{1068})"
DoEvents
Set wdDoc = CreateObject("Word.Application")
'ActiveSheet.Paste
With CreateObject("Outlook.Application").CreateItem(0)
Set doc = .GetInspector.WordEditor
doc.Range(0, 0).Paste
.display
.To = ""
.CC = ""
.htmlbody = "Dear All, " & Chr(10) & Chr(10) & "I kindly remind you that forecasts for program " & Chr(10) & Chr(10) _
& "Please enter your forecast at the link below." _
& Chr(10) & Chr(10) & lien & Chr(10) & Chr(10) & "Best Regards," & .htmlbody
.Subject = "Test:"
.Importance = olImportanceHigh
End With
End Sub
I'm using this code to create an e-mail
however, I would like to send the content that is in the range A5 to B100, like this:
A5 B5
A6 B6
...
A100 B100
what do you suggest?
current code, looks like this:
Public Function Sendemail()
On Error GoTo Ende
esubject = "CBP Review for Approval"
sendto = Range("G1") & Range("H1")
ccto = Range("G1")
ebody = "Please see below a" & vbNewLine & Range("A5") & " " & Range("B5") & vbCrLf & "Best regards" & vbCrLf & "Your Partner"
Set app = CreateObject("Outlook.Application")
Set itm = app.CreateItem(0)
With itm
.Subject = esubject
.To = sendto
.CC = ccto
.Body = ebody
.Display
End With
Set app = Nothing
Set itm = Nothing
the way it is now, just writes A5 and B5 but need a loop to write the other ones
many thanks
I wrote out the answer, but your questions states you already know what you have to do. Why not just look it up? First result from google search "vba loop"
Can use UsedRange.Rows.Count to get last row. If your loop is beyond your range of data, or has blanks, you'll want to uncomment the if statement. So you don't end up with a bunch of newlines.
Dim sData as string
For iRowCounter = 5 to ??
'if Range("A" & iRowCounter) <> "" or Range("B" & iRowCounter) <> "" then
sData = sData & Range("A" & iRowCounter) & " " & Range("B" & iRowCounter) & vbNewline
'end if
Next
eBody = "Please see..." & vbnewline & sData & "Best Regards..."
You can use a For loop to build up the body of your message one row at a time. Replace the following line:
ebody = "Please see below a" & vbNewLine & Range("A5") & " " & Range("B5") & vbCrLf & "Best regards" & vbCrLf & "Your Partner"
with the following code:
ebody = "Please see below a" & vbNewLine
For i = 5 To 100
If Range("A" & i) <> "" or Range("B" & i) <> "" Then
ebody = ebody & Range("A" & i) & " " & Range("B" & i) & vbCrLf
End If
Next i
ebody = ebody & "Best regards" & vbCrLf & "Your Partner"
Note the two different uses of concatenation (& operator), one to add new lines to the existing body:
ebody = ebody & "more text to add..."
and another to create the cell reference on each line. Range("A" & i) inside the loop will result in cells A5 to A100 (and similarly B5 to B100) to be added to the message.
Finally, the If statement will make sure that only rows that have data in either cell A or B will be added to your email.
I have the following code where the adress doen't work... I wonder how I can select the e-mail adress value out of a cell because with cells(1,1).value it doesn't seem to work in my case.
Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B").End(xlUp).Row
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Lien = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown| " & Project_number & " " & Project_name & "| Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & "Please enter your forecast " & "<a href=lien>here.</a>" & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End with
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
You didn't set i before using it for your Adresse variables, moving the declaration of these variables in your loop should solve your problem:
Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B").End(xlUp).Row
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Lien = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown| " & Project_number & " " & Project_name & "| Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & "Please enter your forecast " & "<a href=lien>here.</a>" & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End with
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
I have a created a macro for my spreadsheet which can sent out emails successfully.
However, it can only send e-mails of each individual part numbers which are over the due date. Which means if I have 100 over the due date part numbers, there will be 100 emails being sent out.
I would like my macro to send the email by a range of cells which are of similar product (eg. printer) and are over the due date. There can be other products like laptop, camera, webcam as well. I need to do this as i don't want to spam the receiver's inbox.
How do I do that?
Sub LabelArtworkRelease()
Dim OutApp As Object
Dim Message1 As Object
Dim cell As Range
Dim emailBody As String
Dim Signature As String
'GET DEFAULT EMAIL SIGNATURE
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
'End
Application.ScreenUpdating = False
'Create a new Outlook session
Set appOutlook = CreateObject("Outlook.Application")
On Error GoTo cleanup
'Declare header variables
partnumber = Range("A3").Value
productfamily = Range("B3").Value
desc = Range("C3").Value
artworkactual = Range("F3").Value
artworkexpected = Range("G3").Value
remark = Range("L3").Value
On Error Resume Next
'if artwork actual date is later than artwork expected date
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If Cells(cell.Row, "G").Value < Cells(cell.Row, "F").Value And Cells(cell.Row, "L").Value = "Incomplete" Then
'Create a new message
Set Message1 = appOutlook.CreateItem(olMailItem)
'Create default message
emailBody = "<Font face=Calibri>Hi " & Cells(cell.Row, "D").Value & " , <p>" _
& "Please be reminded that the following part numbers - is/are over the expected artwork release date. <p> Kindly act on the following item(s): <br> " _
& "<table border=1><tr><th>" _
& partnumber & "</th>" _
& "<th>" & productfamily & "</th>" _
& "<th>" & desc & "</th>" _
& "<th>" & artworkactual & "</th>" _
& "<th>" & artworkexpected & "</th>" _
& "<th>" & remark & "</th>" _
& "<tr>" _
& "<td>" & Cells(cell.Row, "A").Value & "</td>" _
& "<td>" & Cells(cell.Row, "B").Value & "</td>" _
& "<td>" & Cells(cell.Row, "C").Value & "</td>" _
& "<td>" & Cells(cell.Row, "F").Value & "</td>" _
& "<td>" & Cells(cell.Row, "G").Value & "</td>" _
& "<td>" & Cells(cell.Row, "L").Value & "</td></tr></table><br /></font>" & Signature
With Message1
.to = "email#email.com"
.CC = Cells(cell.Row, "N") & ";" & Cells(cell.Row, "O")
.Subject = "Reminder for Label Artwork Tracking (Artwork Expected Date) - Product Family (" & Cells(cell.Row, "B").Value & ")"
.HTMLBody = emailBody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
First you can alphabetically sort the column with Product names and then within if statement you put a condition like:
If Cells(cell.Row, "Product name column").Value <> Cells(cell.Row + 1, "Product name column").Value then
So macro runs the rest of the code only after reaching the last item with the same name.