[VBA] Send mail with range in body, and unique value in A:A based on reciever

orjanmen

New Member
Joined
May 21, 2014
Messages
27
Office Version
  1. 365
Platform
  1. Windows
Hi,

I want to send a mail with a range in body. In A:A there is a link to a page. One of the parameters in this link is the recievers mail address.

Is this even possible?

I usually find a lot of good examples on Excel Automation - Ron de Bruin, but none of them match my needs this time.

Would be glad for some input.
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
I think some more detail would be helpful.
Link to what sort of page?
Give an example of the link with receivers address.
 
Upvote 0
Hi,

Thanks for your reply.

I got a range with recievers


Each reciever get an e-mail with a range in the body. As an example, this would be the mail body for "example@mail.com":

*******************
LinkColor
LinkBlue
LinkYellow
LinkGreen
*****************

As you can see if you click on the link, recievers mail address is integrated in the link.


More understandable?
 
Upvote 0
Hi

please forgive the hacked together code....
See if it does what you need then maybe look to improve it.

Basically the macro cycles through each email address in column D (You didn't specify where email addresses were stored).
It then cycles through each link in column A extracts the current email address and replaces it with the one from Column D, rewriting each link with the new email address.

This required finding code that replaces email addresses. It finds the @ symbol and works back to the '=' as the start location
Works forward from @ to the &.
So that bit relies on the link being formed as specified at all times.

The code was obtained from a video in the link specified. It was a function but my ability is average and I found it easier to use it in code than a function.
I'll continue to play with it to see if I can do that.

The normal RangetoHTML function doesn't copy hyperlinks just the cell text 'Link' so I had to add a bit of code to that function to do that.
The stackoverflow link shows the origin.

Lets hope it gets you started.

Code:
Sub Test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Dim AtLoc As Integer
Dim L As Integer
Dim i As Integer

Set mailRng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))

Set linkRng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))

Set rng = Range("A1:B4")

For Each mailAddr In mailRng

For Each Cell In linkRng

s = Cell.Hyperlinks(1).Address

'https://www.coursera.org/lecture/excel-vba-for-creative-problem-solving-part-2/example-extracting-email-addresses-from-mixed-string-formats-Rydqz

'Extracts the current email address in the link
L = Len(s)
AtLoc = InStr(s, "@")
For i = AtLoc - 1 To 1 Step -1

If Mid(s, i, 1) = "=" Then
StartLoc = i + 1
Exit For
ElseIf i = 1 Then
StartLoc = 1
End If
Next i

For i = AtLoc + 1 To L
If Mid(s, i, 1) = "&" Then
EndLoc = i - 1
Exit For
ElseIf i = L Then
EndLoc = L
End If
Next i


Email = Mid(s, StartLoc, EndLoc - StartLoc + 1)

'Replaces the current address with the one in Column D and rewrites the link
Addr = Cell.Address(0, 0)
Hlink = Cell.Hyperlinks(1).Address
Hlink = Replace(Hlink, Email, mailAddr)
ActiveSheet.Hyperlinks.Add Range(Addr), Address:=Hlink, TextToDisplay:="Link"


Next

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = mailAddr
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

Next


With Application
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim i As Integer
Dim Hlink As Hyperlink

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

Application.ScreenUpdating = False

rng.Copy
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
.UsedRange.EntireColumn.AutoFit
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0

For i = 7 To 12
With .UsedRange.Borders(i)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Next i

End With

'https://stackoverflow.com/questions/35268674/how-to-preserve-retain-hyperlinks-in-email-body-when-using-rangetohtml-from-exce

For Each Hlink In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
Address:=Hlink.Address, _
TextToDisplay:=Hlink.TextToDisplay
Next Hlink

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

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=")
TempWB.Close savechanges:=False
Kill TempFile
Application.ScreenUpdating = True
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
 
Upvote 0
Hi,

Thank you so much for your help. It worked fine.

However, the link also reffers to the cell value in B:B. I'm not good in VBA, but have tried to modify the code you gave me by adding " & cell.Offset(0, 1)":
VBA Code:
Addr = cell.Address(0, 0)
Hlink = cell.Hyperlinks(1).Address
Hlink = Replace(Hlink, Email, mailAddr)
ActiveSheet.Hyperlinks.Add Range(Addr), Address:=Hlink & cell.Offset(0, 1), TextToDisplay:="Link"

This works fine the first time, but next time I run it, it don't remove previous value. I therefor need a function to delete everything after last "=", I have tried "find and replace", "Array" etc, but it don't work properly (I guess it is because of the hyperlink functionality).

I would really appreciate some assistance on this issue as well.

Thank you so much.
 
Upvote 0
Greetings,

I managed to fix it myself by changing my table to:

LinkColor
Link£Blue
Link£Yellow
Link£Green

and then make it also search for "£" in the same way as it search for "@" in code from #4:
VBA Code:
l = Len(s)
AtLoc = InStr(s, "£")
For i = AtLoc - 1 To 1 Step -1

If Mid(s, i, 1) = "=" Then
StartLoc = i + 1
Exit For
ElseIf i = 1 Then
StartLoc = 1
End If
Next i

For i = AtLoc + 1 To l
If Mid(s, i, 1) = "&" Then
EndLoc = i - 1
Exit For
ElseIf i = l Then
EndLoc = l
End If
Next i

Oppgnr = Mid(s, StartLoc, EndLoc - StartLoc + 1)

...and adding the fourth line here:
VBA Code:
Addr = cell.Address(0, 0)
Hlink = cell.Hyperlinks(1).Address
Hlink = Replace(Hlink, Email, mailAddr)
Hlink = Replace(Hlink, Oppgnr, cell.Offset(0, 1))
ActiveSheet.Hyperlinks.Add Range(Addr), Address:=Hlink, TextToDisplay:="Link"

Please forgive the hacked together code ;)

Thank you so much for your time and help.
 
Upvote 0
Hi,

sorry I didn't respond. I was away for Christmas.
Glad you sorted the final bit it out yourself.
(y)
 
Upvote 0

Forum statistics

Threads
1,223,243
Messages
6,170,971
Members
452,371
Latest member
Frana

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top