Including Hyperlinks in an email depending on the text in the Email.

[Atrax]

I'm new so if i'm doing something wrong in my explanation or not giving enough information please let me know.

So I've been working on this file for some time getting it all set up thinking that adding a hyperlink would not be too difficult, however it is giving me problems. So I was hoping someone could offer some suggestions.

Here is my situation, I have different templates of text in my file and these templates are selected based on a person's demographic, interests, and my suggestions to them.

So for example the introduction for an email to an older person is written differently that one to a younger person. The idea is to make them as personal as possible. The suggestions part is also linked to the file, I look at their interest and their demographic information and mark a box, the templates of the activities marked are placed into the email body. Now in the part where I offer my suggestions I want to insert hyperlinks to a webpage that shows a schedule of when this suggestion takes place. Now since a hyperlink will not transfer when you concatenate I will need to find a different method of adding them in. I have one tab where every person's email is combined using concatenate to create their personal emails and then a macro is used to send them using HTML.

Should I not have my templates in excel to create the email?
- for instance do I need to set up the templates in word or something different?
Do I need to change my VBA code to include all the different options?

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer


On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")


With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Sheets("Email 1 Sheet").Visible = True
Sheets("Email 1 Sheet").Select

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet


'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A3:C" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A


'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=False


'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))


'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount


'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value


'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then


With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.to = Cws.Cells(Rnum, 1).Value
.Subject = "Test mail"
.HTMLBody = RangetoHTML(rng)


.Send
End With
On Error GoTo 0


Set OutMail = Nothing
End If


'Close AutoFilter
Ash.AutoFilterMode = False


Next Rnum
End If


cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
Sheets("Email 1 Sheet").Visible = False
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


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


'Copy the range and create a new workbook to past the data in
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
.Cells(1).EntireRow.Delete
.Columns("A:B").EntireColumn.Delete
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With


'Publish the sheet to a htm file
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


'Read all data from the htm file into RangetoHTML
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=")


'Close TempWB
TempWB.Close savechanges:=False


'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Thank you

 

[Atrax]

So I worked on this for myself and now I have it so my email gets pasted into a word file which contains a specific macro which will insert the hyperlinks for me. Then from this word file it will paste the content into the mail body.
This solves my hyperlink problem, however it seems to significantly slow down the process. This is probably because I combined a bunch of different things without really knowing what I'm doing. So what I wanted to know is if there is anything I can do to speed up the process. I am very much new to all of this so please be patient.

Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
     
    Sheets("Email 1 Sheet").Visible = True
    Sheets("Email 1 Sheet").Select
     
    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet
    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A3:C" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A
    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=False
    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount
            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value
            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

    Dim TempWB As Workbook
    Dim strBody As String
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    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
        .Cells(1).EntireRow.Delete
        .Columns("A:B").EntireColumn.Delete
        .Cells(1).Copy
    End With
 
    Dim wdApp As Object, editor As Object
    Dim wdDoc As Object
    'Open new instance of Microsoft Word
    Set wdApp = CreateObject("Word.Application")
     'Make application visible
    wdApp.Visible = True
   Set wdDoc = wdApp.Documents.Open("P:\member retention intern\At risk members\WordMacro.docm")
        ' tell word to paste the contents of the clipboard into the new document
    wdApp.Selection.Paste
        'set the search range
    wdApp.Run MacroName:="FindAndHyperlink"
   
    wdApp.ActiveDocument.Content.Copy
    
    
    'Close TempWB
    'Delete the htm file we used in this function
    
   
                Set OutMail = OutApp.CreateItem(0)
                On Error Resume Next
                With OutMail
                    .To = Cws.Cells(Rnum, 1).Value
                    .Subject = "Test mail"
                    Body = "The email below is Word-formatted text"
    .Display
End With

Set oMailWordDoc = OutApp.ActiveInspector.WordEditor

oMailWordDoc.Application.Selection.Paste
    TempWB.Close savechanges:=False
    wdDoc.Close savechanges:=False
    wdApp.Quit
Set oMailWordDoc = Nothing
    Set TempWB = Nothing
    Set wdApp = Nothing
    Set wdDoc = Nothing
                On Error GoTo 0
                Set OutMail = Nothing
            End If
            'Close AutoFilter
            Ash.AutoFilterMode = False
        Next Rnum
    End If
cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub