Как сделать так, чтобы гиперссылки в столбце таблицы были кликабельны при отправке в тело письма? - PullRequest
Новая
       9

Как сделать так, чтобы гиперссылки в столбце таблицы были кликабельны при отправке в тело письма?

0 голосов
/ 28 февраля 2020

Я пытаюсь отправить электронное письмо через Outlook, используя VBA.

У меня есть столбец, заполненный гиперссылками. Когда электронное письмо создается, гиперссылки превращаются в обычный текст, и на них нельзя нажать.

Я ссылаюсь на столбец с помощью ячеек (row_num, 1), поскольку все гиперссылки уникальны.

Как сделать они отображаются как гиперссылки? 

Sub SendEmail()

Dim olook As Outlook.Application
Dim omailitem As Outlook.MailItem
Dim i As Byte, row_num As Byte
row_num = 2

Set olook = New Outlook.Application

For i = 1 To 15

    Set omailitem = olook.CreateItem(0)

    With omailitem

        .To = Sheets(1).Cells(row_num, 2)
        .Subject = "Tool Notification"

        .Body = "Hello!" & vbNewLine & vbNewLine & _
          "Below are the link(s) to the task(s) that you have due on: " & _
          Cells(row_num, 4).Value & _
          vbNewLine & vbNewLine & "Link: " & Cells(row_num, 1).Value & _
          vbNewLine & vbNewLine & "Thank you," & _
          vbNewLine & vbNewLine & "Tool"

        .Display

    End With

    row_num = row_num + 1

Next

End Sub

Пример данных
https://i.stack.imgur.com/m9Stx.png

1 Ответ

0 голосов
/ 28 февраля 2020

Проверьте комментарии к коду и настройте его в соответствии с вашими потребностями.

Это должно быть вставлено в стандартный модуль.

РЕДАКТИРОВАТЬ: С учетом накопления ссылок отправителем

Код: 

Option Explicit

Sub SendEmail()

    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem

    Dim targetSheet As Worksheet
    Dim targetRange As Range
    Dim cell As Range

    Dim lastRow As Long

    Dim recipientAddr As String
    Dim bodyContent As String
    Dim duedateFormat As String
    Dim linkFormat As String

    ' Set reference to target Sheet (replace 1 with the sheet's name or codename)
    Set targetSheet = ThisWorkbook.Worksheets(1)

    ' Find last cell in column b
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, 2).End(xlUp).Row

    ' Set target range
    Set targetRange = targetSheet.Range("B2:B" & lastRow)

    ' Start new outlook instance
    Set olApp = New Outlook.Application

    ' Loop through each cell in column B
    For Each cell In targetRange.Cells

        ' If cell has data
        If cell.Value <> vbNullString Then

            ' Check if is the same recipient as next
            If cell.Value = cell.Offset(1, 0).Value Then

                linkFormat = linkFormat & "<a href=" & Chr(34) & cell.Offset(0, -1) & Chr(34) & ">" & cell.Offset(0, -1) & "</a><br>"

            Else

                linkFormat = linkFormat & "<a href=" & Chr(34) & cell.Offset(0, -1) & Chr(34) & ">" & cell.Offset(0, -1) & "</a>"

                ' Collect email data from cells
                recipientAddr = cell.Value
                duedateFormat = Format(cell.Offset(0, 2).Value, "mm-dd-yyyy")


                ' Build the link string
                bodyContent = "Hello!<br><br>" & _
                              "Below are the link(s) to the task(s) that you have due on: " & duedateFormat & "<br><br>" & _
                              "Link(s): <br>" & _
                              linkFormat & "<br><br>" & _
                              "Thank you,<br><br>" & _
                              "Tool"

                ' Create the mail item and display it
                Set olMail = olApp.CreateItem(olMailItem)

                With olMail

                    .To = cell.Value
                    .Subject = "Tool Notification"
                    .HTMLBody = bodyContent

                    .Display

                End With

                ' Reset the link
                linkFormat = vbNullString

            End If

        End If

    Next cell

End Sub

Дайте мне знать, если это работает

...