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
