Скопируйте и вставьте гиперссылку из Excel в основной текст VBA. - PullRequest
Новая
       35

Скопируйте и вставьте гиперссылку из Excel в основной текст VBA.

0 голосов
/ 12 февраля 2019

Может кто-нибудь, пожалуйста, помогите мне.Я много искал в сети, и до сих пор я иду пустым.

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

В настоящее время у меня есть vbaСкрипт, который просматривает лист, проверяя дату займа и, если срок возврата в течение 7 дней после возврата, автоматически отправляет электронное письмо «получателю» с данными, извлеченными из листа.

Как только электронное письмо отправлено, оно обновляет лист с информацией о том, когда электронное письмо было отправлено.Все работает нормально, кроме гиперссылки на их документ.

Все, что я получаю, это текст из ячейки.Можно ли это сделать?

Мой код ниже.Я уверен, что мои недостатки новичка будут выделены, но благодарны за любую конструктивную критику ... 

Private Sub Workbook_Open()
Worksheets("Tracker").Select

    Dim OutApp As Object
    Dim OutMail As Object
    Dim lLastRow As Long
    Dim lRow As Long
    Dim sSendCC As String
    Dim sSubject As String
    Dim sTemp As String
    Dim strBody As String
    Dim Sigstring As String
    Dim Signature As String
    Dim sURL As String

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    sSendCC = Range("D3").Value
    sSubject = "You are within 7 days of the deadline"
    Sigstring = Environ("appdata") & _
                "\Microsoft\Signatures\Mike.htm"
    If Dir(Sigstring) <> "" Then
        Signature = GetBoiler(Sigstring)
    Else
        Signature = ""
    End If

    lLastRow = Cells(Rows.Count, 5).End(xlUp).Row
    For lRow = 7 To lLastRow
    sURL = Cells(lRow, 5).Value
        If Not IsEmpty(Cells(lRow, 3)) Then
            If Cells(lRow, 8) <> "YES" Then
                If Cells(lRow, 7) <= Now() + 7 Then
                    Set OutMail = OutApp.CreateItem(0)

                    strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
                                "You have previously signed  the loan of equipment from my department." & "<br><br>" & _
                                "You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
                                "Description of loan:  " & Cells(lRow, 4).Value & "<br><br>" & _
                                "Hyperlink:  " & Cells(lRow, 5) & "<br><br>" & _
                                "Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"

                    With OutMail
                        .Display
                    End With
                    On Error Resume Next
                    With OutMail
                        .To = Cells(lRow, 3)
                            If sSendCC > "" Then .CC = sSendCC
                        .Subject = sSubject
                        .HTMLBody = "<html><body>" & strBody & Signature
                        SendKeys ("^{ENTER}")
                    End With
                    Set OutMail = Nothing
                    Cells(lRow, 8) = "YES"
                    Cells(lRow, 9) = "E-mail sent on: " & Now()
                    End If

                End If
            End If

    Next lRow
    Set OutApp = Nothing
End Sub

1 Ответ

0 голосов
/ 12 февраля 2019

Вам необходимо добавить тег <a href="[SOME_URL_ADDRESS]">[Some_Hyperlink_Text]</a> в ваш код.

попробуйте этот измененный бит вашего кода 

sURL = Cells(lRow),5).Hyperlinks(1).Address

            strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
                        "You have previously signed  the loan of equipment from my department." & "<br><br>" & _
                        "You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
                        "Description of loan:  " & Cells(lRow, 4).Value & "<br><br>" & _
                        "Hyperlink:   <a href=""" & sURL & """>'Insert Hyperlink Text Here'</a><br><br>" & _
                        "Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"

В приведенном выше коде, который я изменил, я предполагаючто Cells(lRow, 5).value (sURL переменная) является URL (а не гиперссылкой на листе).Если это гиперссылка на листе, возможно, вам потребуется извлечь ссылку.

...