Add hyperlink from excel VBA to outlook appointment

Question

I have code that works fine in all aspects, but I can not find a way to create a hyperlink in an Outlook appointment. The address is placed in column H in Excel, and I want to use VBA to export it to a certain calendar. Any help would greatly be appriciated.

My code is as follows:

Sub Appointments()
        
        Const olAppointmentItem As Long = 1
        
        Dim OLApp As Object
        Dim OLNS As Object
        Dim OLAppointment As Object
        Dim miCalendario As Object
        Dim r As Long
        On Error Resume Next
        Set OLApp = GetObject(, "Outlook.Application")
        If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        
        If Not OLApp Is Nothing Then
        
            Set OLNS = OLApp.GetNamespace("MAPI")
            OLNS.Logon "Outlook"
               
            b = 1
            r = 2
            
            Dim mysub, myStart, myEnd, mydes, myallday
            While Len(Cells(r, 5).Text) <> 0
                mysub = Cells(r, 7)
                If Not Cells(r, 13).Value = 0 Then
                mysub = mysub & "(s. " & Cells(r, 13).Value & ")" & vbCrLf
                End If
                '& ", " & Cells(r, 3)
                myStart = DateValue(Cells(r, 1).Value) + Cells(r, 2).Value
                myEnd = DateValue(Cells(r, 1).Value) + Cells(r, 3).Value
        
        mydes = ""
            
            
        Set miCalendario = OLApp.Session.GetDefaultFolder(9).Folders(ActiveSheet.Name)
        
        Set OLAppointment = miCalendario.Items.Add(olAppointmentItem)
        Dim olItems As Items
        Dim olApptItem As Outlook.AppointmentItem
        Set olItems = miCalendario.Items
        Set olApptItem = miCalendario.Items.GetFirst
           
            'add appointments
         On Error Resume Next
            With OLAppointment
        .Subject = mysub
        .Start = myStart
        .End = myEnd
        .Body = mydes
         
        If Not Cells(r, 1).Value = 0 Then
        
        If Not Cells(r, 8).Value = 0 Then
        mydes = mydes & Cells(1, 8).Value & " - " & Cells(r, 8).Value & vbCrLf
        End If
           
        .Body = mydes
        
        End If
        
        
        
        .Location = Cells(r, 4).Value    .Save
        
            End With
        r = r + 1
        b = b + 1
        Wend
            Set OLAppointment = Nothing
            Set OLNS = Nothing
            Set OLApp = Nothing
        
        End If
End Sub
    

Answer 1

You need to use .HTMLBody insted .Body

.HTMLbody = <a href="link">"link_Mask"</a>

I hope it'll help