Вставка гиперссылки в тело Outlook с помощью Word VBA - PullRequest
Новая
       31

Вставка гиперссылки в тело Outlook с помощью Word VBA

0 голосов
/ 06 июня 2018

Как я могу добавить гиперссылку на последнюю часть моего электронного письма в сочетании с текстом?

Это должно быть последнее предложение в моем абзаце

"Если у вас есть вопросы/ уточнения, пожалуйста, свяжитесь с Service Management по адресу Service_Management@xyz.com "

Слово" Service_Management@xyz.com "должно иметь гиперссылку.

Я пытался редактировать кодиз этого: 

wd.Hyperlinks.Add wd.Range(wd.Paragraphs.Count), _
  "mailto:Service_Management@xyz.com" & "Service_Management@xyz.com"

Проблема в том, что нижняя часть тела письма становится ссылкой.И в теле письма нет текстового дисплея.Как правильно объявить ссылку, чтобы она не влияла на другую часть диапазона? 

 Sub AUTOMAIL()

    Dim ol As Object 'Outlook.Application
    Dim olEmail As Object 'Outlook.MailItem
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document
    Dim rCol As Collection, r As Range, i As Integer
    Dim Table1 As Collection

    Dim ETo As String
    Dim CTo As String

    ETo = Join(Application.Transpose(Worksheets("Data Entry").Range("AD5:AD100").Value), ";")
    CTo = Join(Application.Transpose(Worksheets("Data Entry").Range("AI5:AI15").Value), ";")

     '/* if outlook is running use GO, create otherwise */
    Set ol = GetObject(Class:="Outlook.Application")
    Set olEmail = ol.CreateItem(0) 'olMailItem

    Set Table1 = New Collection

    With Table1
        .Add Sheet14.Range("A1:O20")
    End With

    Set rCol = New Collection
    With rCol   
        .Add Sheet11.Range("a1:i1", "a6:i20")
        .Add Sheet10.Range("a1:i1", "A6:I20")
        .Add Sheet9.Range("A1:J18")
    End With

    With olEmail
        .To = ETo
        .CC = CTo
        .Subject = "Step+ Volume Tracker, Data Entry/Workflow Ageing Report and Rejection Report | " & Format(Date, "MMMM dd, yyyy") & " | 9:15AM"

        '/* bonus basic html */
        .HTMLBody = "<html><body style=""font-family:calibri"">" & _
                    "<p><b>Dear All,</b><br><br> Please see below summary of invoices and links to the <b>Volume Tracker</b> and <b>Ageing Report</b> (Data Entry and Workflow)." & _
                    "</p></body></html>"

           Set olInsp = .GetInspector
           If olInsp.EditorType = 4 Then 'olEditorWord
               Set wd = olInsp.WordEditor
               For i = 1 To Table1.Count '/* iterate all ranges */
                   Set r = Table1.Item(i): r.Copy
                   wd.Range.insertparagraphafter
                   wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
                   '16 - wdFormatOriginalFormatting
            Next
        End If
        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = Chr(11) & "Please click on this link to view the details:"

        Set olInsp = .GetInspector
        If olInsp.EditorType = 4 Then 'olEditorWord
            Set wd = olInsp.WordEditor
            For i = 1 To rCol.Count '/* iterate all ranges */
                Set r = rCol.Item(i): r.Copy
                wd.Range.insertparagraphafter
                wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
                '16 - wdFormatOriginalFormatting
            Next
        End If

        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = Chr(11) & "Please click on this link to view the details:" & vbCrLf & "Those who are encountering problems accessing the Sharepoint site, please refer to attachment for Data Entry and Workflow Report. " & Chr(11) & "Please note though that the file has been truncated, complete details of the report are available in the links indicated above." & Chr(11) & Chr(11) & "Should you have questions/clarifications, kindly reach out to Service Management at"
        wd.Range(wd.Paragraphs(wd.Paragraphs.Count).Range.Characters(98).Start, _
        wd.Paragraphs(wd.Paragraphs.Count).Range.Characters(128).End).Font.Bold = True

        wd.Range.Hyperlinks.Add Anchor:=wd.Range, _
        Address:="mailto:Service_Management@xyz.com"
        wd.Range.Font.Size = 10
        .Display

    End With

End Sub

1 Ответ

0 голосов
/ 07 июня 2018

Переместите выделение в конец сообщения, затем вставьте гиперссылку. 

'Reference to Word Object Library required
 objSel.EndKey Unit:=wdStory

' Reference to Word Object Library not required
objSel.EndKey Unit:=6

Это менее шумный пример, чем код в вашем вопросе. 

Sub AUTOMAIL()

    Dim ol As Object 'Outlook.Application
    Dim olEmail As Object 'Outlook.MailItem
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document

     '/* if outlook is running use GO, create otherwise */
    Set ol = GetObject(Class:="Outlook.Application")
    Set olEmail = ol.CreateItem(0) 'olMailItem

    With olEmail

        '/* bonus basic html */
        .HTMLBody = "<html><body style=""font-family:calibri"">" & _
                    "<p><b>Dear All,</b><br><br> Please see below summary of invoices and links to the <b>Volume Tracker</b> and <b>Ageing Report</b> (Data Entry and Workflow)." & _
                    "</p></body></html>"

        Set olInsp = .GetInspector
        If olInsp.EditorType = 4 Then 'olEditorWord
            Set wd = olInsp.WordEditor
            wd.Range.InsertParagraphAfter
        End If

        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = Chr(11) & "Please click on this link to view the details:" & vbCrLf & "Those who are encountering problems accessing the Sharepoint site, please refer to attachment for Data Entry and Workflow Report. " & Chr(11) & "Please note though that the file has been truncated, complete details of the report are available in the links indicated above." & Chr(11) & Chr(11) & "Should you have questions/clarifications, kindly reach out to Service Management at"

        wd.Range.InsertParagraphAfter

        Dim objSel As Object
        Set objSel = wd.Windows(1).Selection

        'Reference to Word Object Library required
        'objSel.EndKey Unit:=wdStory

        ' Reference to Word Object Library not required
        objSel.EndKey Unit:=6

        wd.Range.Hyperlinks.Add Anchor:=objSel.Range, _
          Address:="mailto:Service_Management@xyz.com"

        .Display

    End With

End Sub
...