Dynamic url email linked to word

[rjp847]

Hi guys, hoping you can help me out. I'm trying to get the "link" in this code to show as a full working variable hyperlink within the email contents. At the moment it generates the text in the email but I have to hyperlink it manually.


Code is:



Sub createemail()

Dim ol As Outlook.Application
Dim olm As Outlook.MailItem


Dim wd As Word.Application
Dim doc As Word.Document


Set ol = New Outlook.Application

For r = 3 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

Set olm = ol.CreateItem(olMailItem)


Set wd = New Word.Application
wd.Visible = True
Set doc = wd.Documents.Open(Cells(1, 4).Value)


With wd.Selection.Find
.Text = "<<date>>"
.Replacement.Text = Sheet1.Cells(r, 2).Value
.Execute Replace:=wdReplaceAll
End With

With wd.Selection.Find
.Text = "<<time>>"
.Replacement.Text = Sheet1.Cells(r, 3).Value
.Execute Replace:=wdReplaceAll
End With

With wd.Selection.Find
.Text = "<<password>>"
.Replacement.Text = Sheet1.Cells(r, 4).Value
.Execute Replace:=wdReplaceAll
End With

With wd.Selection.Find
.Text = "<<link>>"
.Replacement.Text = Sheet1.Cells(r, 13).Value
.Execute Replace:=wdReplaceAll
End With

doc.Content.Copy


With olm
.Display
.To = ""
.Subject = Sheet1.Cells(r, 1)
.CC = Sheet1.Cells(r, 9)


Set Editor = .GetInspector.WordEditor
Editor.Content.Paste
'.Send
End With


Set olm = Nothing

Application.DisplayAlerts = False
doc.Close SaveChanges:=False
Set doc = Nothing
wd.Quit
Set wd = Nothing
Application.DisplayAlerts = True

Next

End Sub

 

[Macropod]

For example (partly tested):

Sub SendEmails()
Dim olApp As New Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlSht As Excel.Worksheet, r As Long
Set xlSht = Worksheets("Sheet1")
wdApp.Visible = True
For r = 3 To xlSht.Cells(Rows.Count, 1).End(xlUp).Row
  Set wdDoc = wdApp.Documents.Open(xlSht.Cells(1, 4).Text, , , False, , , , , , , , False)
  With wdDoc
    With .Range
      With .Find
        .Forward = True
        .Wrap = wdFindContinue
        .Text = "<<date>>"
        .Replacement.Text = xlSht.Cells(r, 2).Text
        .Execute Replace:=wdReplaceAll
        .Text = "<<time>>"
        .Replacement.Text = xlSht.Cells(r, 3).Text
        .Execute Replace:=wdReplaceAll
        .Text = "<<password>>"
        .Replacement.Text = xlSht.Cells(r, 4).Text
        .Execute Replace:=wdReplaceAll
        .Text = "<<link>>"
        xlSht.Cells(r, 13).Range.Copy
        .Replacement.Text = "^c"
        .Execute Replace:=wdReplaceAll
        '.Wrap = wdFindStop
      End With
      'Do While .Find.Execute
        '.Hyperlinks.Add .Duplicate, xlSht.Cells(r, 13).Text
        '.Collapse wdCollapseEnd
      'Loop
    End With
    .Range.Copy
    .Close False
  End With
  Set olMail = olApp.CreateItem(olMailItem)
  With olMail
    .Display
    .To = ""
    .Subject = xlSht.Cells(r, 1).Text
    .CC = xlSht.Cells(r, 9).Text
    Set olInsp = .GetInspector
    Set wdDoc = olInsp.WordEditor
    wdDoc.Content.Paste
    '.Send
  End With
  wdDoc.Close False
Next
wdApp.Quit: olApp.Quit
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub

As coded, it is assumed your Excel hyperlinks are actual hyperlinks. If so, you can delete the commented-out lines immediately below:

        xlSht.Cells(r, 13).Range.Copy
        .Replacement.Text = "^c"
        .Execute Replace:=wdReplaceAll

Otherwise, delete/comment out these three lines and activate the commented-out lines immediately below.

 

[rjp847]

Thanks! I'll give it a shot