Hyperlink in Serien-E-Mail in Makro
15.05.2022 18:48:40
Marko
ich möchte in Serien-E-Mails, die mit einem Makro erzeugt werden, zwei Hyperlinks einfügen. Diese befinden sich im Sheet "Abr_Mgl_2" in Zelle "S59" und "S62". Dort habe ich diese als Hyperlink definiert. In der E-Mail werden die Inhalte der Zellen übernommen, jedoch nicht als Link dargestellt. Wenn ich hinter den Link den Cursor setze und Enter drücke, wird diese als Link - also blau und mit Unterstrich - dargestellt.
Habt Ihr eine Idee, wie ich diese Aktion bereits in den Code einbauen kann?
Vielen Dank und Gruß, Marko
Sub E_Mail_Mgl_Abr_2_Info()
'Info E-Mail versenden aus Sheet Mgl_Abr_2
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim app As Object
Dim file As String
Dim isNew As Boolean
Dim olAPP As Object
Dim olOldBody As String
Dim signature As String
'aktueller Druckbereich A1:H61 ggf anpassen!
file = Sheets("Mgl_Abr_2").Range("L21").Text & ".pdf"
Sheets("Mgl_Abr_2").Range("A1:H564").ExportAsFixedFormat xlTypePDF, Environ("TEMP") & "\" & file
On Error Resume Next
Set app = GetObject(, "Outlook.Application")
If app Is Nothing Then
Set app = CreateObject("Outlook.Application")
isNew = True
End If
With app.CreateItem(0)
.GetInspector.Display
.To = Sheets("Mgl_Abr_2").Range("M17").Value
.Cc = Sheets("Mgl_Abr_2").Range("M18").Value
.BCC = ""
.Subject = Sheets("Mgl_Abr_2").Range("L19").Value
.htmlbody = "" _
& Sheets("Mgl_Abr_2").Range("S55") _
& "
" & Sheets("Mgl_Abr_2").Range("S56") _
& "
" & Sheets("Mgl_Abr_2").Range("S57") _
& "
" & Sheets("Mgl_Abr_2").Range("S58") _
& "
" & Sheets("Mgl_Abr_2").Range("S59") _
& "
" & Sheets("Mgl_Abr_2").Range("S60") _
& "
" & Sheets("Mgl_Abr_2").Range("S61") _
& "
" & Sheets("Mgl_Abr_2").Range("S62") _
& "
" & Sheets("Mgl_Abr_2").Range("S63") _
& "
" & Sheets("Mgl_Abr_2").Range("S64") _
& "
" & .htmlbody
'S59 und S62 Hyperlinks
.Attachments.Add Environ("TEMP") & "\" & file
.ReadReceiptRequested = True
End With
If isNew Then app.Quit
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub