Hyperlink in outlook appointment

[Dozo2000]

Is it possible to copy a hyperlink from my excelsheet to my outlook agenda?

Everything works fine, but i am not able to get a working link in the body of the appointment.

This is what I have now...

 For r = 4 To 220
        
        Link = Blad1.Cells(r, 125).Hyperlinks(1).Address
        Link = Application.Substitute(Link, "../", "")
        Link = Application.Substitute(Link, "/", "\")
        Link = Application.Substitute(Link, " ", "%20")
        Link = "file:C:///" & Link

   
        If Len(Blad1.Cells(r, 21).Value) = 0 Then GoTo NextRow
        
        sSubject = "[" & Blad1.Cells(r, 1).Value & "]  " & Blad1.Cells(r, 11).Value & " [" & Blad1.Cells(r, 22).Value & "]"
       
  sBody = Link
             
             
        dStartTime = Blad1.Cells(r, 21).Value + TimeValue("10:00:00")
        dEndTime = Blad1.Cells(r, 21).Value + TimeValue("11:00:00")
        sLocation = Blad1.Cells(r, 14).Value
        dReminder = 60
        sName = Blad1.Cells(r, 1).Value
        dCatagory = "Categorie Geel"

 

[LockeGarmin]

Scripting text into an appointment item will require using some Word VBA since it is missing the .HTMLBody property. Here is an example you can use in Excel with Outlook running:

Sub CreateHyperlinkAppointment()

Dim OutApp As Object 'Oultook.Application
Dim Appt As Object 'Outlook.AppointmentItem
Dim Selection As Object 'Word.Selection

    Set OutApp = GetObject(, "Outlook.Application")
    Set Appt = Outlook.Application.CreateItem(olAppointmentItem)
    Appt.Display
    
    Set Selection = Appt.GetInspector.WordEditor.Windows(1).Selection

    Selection.TypeText ("Visit the MrExcel Website:" & vbNewLine)
    Selection.Hyperlinks.Add Selection.Range, "mrexcel.com", TextToDisplay:="Mr. Excel"

    Selection.TypeText (vbNewLine & "Done")

End Sub

 

[Dozo2000]

Thanks! that is working.

But what I am trying to do is to get the hyperlink from my excel file.
Is that possible too?

This is how I create the hyperlink: (it is inside a line that is imported from an other file); It links back to that file.

Target_Data = Target_Workbook.Sheets(1).Cells(6, 4)
    Company = Target_Data
    With Source_Workbook.Sheets(1)
        .Hyperlinks.Add Anchor:=.Cells(i, 11), _
        Address:=Target_Path, _
        ScreenTip:="Open Excel-bestand met basisgegevens van " & Target_Data, _
        TextToDisplay:=Target_Data
    End With

 

[Dozo2000]

And.... that the link will have a relative path...
So the recipient can use (follow) that link.

(auto adding the "user/Dozo200/Documents ......../ - path"

 

[Dozo2000]

I modified it a little..
Is this correct? It seems to work.
I delete my own "users/name.." and it is automatically in the link:

Sub CreateHyperlinkAppointment()
Dim OutApp As Object 'Oultook.Application
Dim Appt As Object 'Outlook.AppointmentItem
Dim Selection As Object 'Word.Selection
    Set OutApp = GetObject(, "Outlook.Application")
    Set Appt = Outlook.Application.CreateItem(olAppointmentItem)
    Appt.Display
    
    Link = Blad1.Cells(186, 115).Value
    Link = Application.Substitute(Link, "\Users\Westerdijk", "..")
    
    Set Selection = Appt.GetInspector.WordEditor.Windows(1).Selection
    Selection.TypeText ("Visit Company Website:" & vbNewLine)
    Selection.Hyperlinks.Add Selection.Range, Link, TextToDisplay:=Blad1.Cells(186, 11).Value
    Selection.TypeText (vbNewLine & "Done")
End Sub

 

[Dozo2000]

I am using sBody.
(sBody = "Bellen met " & Blad1.Cells(r, 15).Value & " over offerte (" & Blad1.Cells(r, 3).Value & ")." & vbNewLine)

How do I get the selection text to sBody, so I can use the code to create my hyperlinks in Outlook Appointments?

 

[Dozo2000]

This is how the appointment is created:

If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = NewDate
olAppt.End = dEndTime
olAppt.ReminderMinutesBeforeStart = dReminder
olAppt.Location = sLocation
olAppt.Categories = dCatagory
olAppt.Close olSave

 

[LockeGarmin]

My apologies for being unresponsive.

Getting hyperlinks from Excel can be done at the Range and Worksheet level objects.

In your case you are wanting to get it at the range level. Something like the following might work:

Sub Run()

Dim excelLink As Excel.Hyperlink
  
  Call Application.ActiveSheet.Hyperlinks.Add(Range("A1"), "mrexcel.com", TextToDisplay:="Mr. Excel")
  Set excelLink = Excel.Range("A1").Hyperlinks(1)
  
  Call CreateHyperlinkAppointment(excelLink)

End Sub

Sub CreateHyperlinkAppointment(excelLink As Excel.Hyperlink)

Dim OutApp As Object 'Oultook.Application
Dim Appt As Object 'Outlook.AppointmentItem
Dim Selection As Object 'Word.Selection

    Set OutApp = GetObject(, "Outlook.Application")
    Set Appt = Outlook.Application.CreateItem(olAppointmentItem)
    Appt.Display
    
    Set Selection = Appt.GetInspector.WordEditor.Windows(1).Selection

    Selection.TypeText ("Visit the MrExcel Website:" & vbNewLine)
    Selection.Hyperlinks.Add Selection.Range, excelLink.Address, TextToDisplay:=excelLink.TextToDisplay

    Selection.TypeText (vbNewLine & "Done")

End Sub

This is how the appointment is created:

If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = NewDate
olAppt.End = dEndTime
olAppt.ReminderMinutesBeforeStart = dReminder
olAppt.Location = sLocation
olAppt.Categories = dCatagory
olAppt.Close olSave

You shouldn't be using an sBody string variable and the .Body property of the Appointment class to build your appointment message. Instead use the Word.Selection object in my example to build your appointment message.

 

[Dozo2000]

No problem! I'm very happy with every help!

So if I undertstand it correctly:


I have to insert the Sub Run() into my macro that I use to create the appointments; and modify it so it can be used in the loop.

Sub Run()
Dim excelLink As Excel.Hyperlink
    Company = Blad1.Cells(r, 11).Value
    Link = Blad1.Cells(r, 131).Value
    Pad = Environ("USERPROFILE")
    Link = Application.Substitute(Link, "C:\Users\Temp", Pad)
    Call Application.ActiveSheet.Hyperlinks.Add(Range("A1"), Link, TextToDisplay:=Company)
    Set excelLink = Excel.Range("A1").Hyperlinks(1)
  
    Call CreateHyperlink(excelLink)
End Sub

And the Sub CreateHyperlinkAppointment(excelLink As Excel.Hyperlink) will be called to fill the body of the appointment.

Not using sBody anymore, but still using the other variable sSubject, date, etc?

Do I understand it right?

Many thanks!

 

[Dozo2000]

I do not understand the .Range("A1")

  Call Application.ActiveSheet.Hyperlinks.Add([B]Range("A1"), [/B]Link, TextToDisplay:=Company)
    Set excelLink = [B]Excel.Range("A1").[/B]Hyperlinks(1)

My links are in Column "J" ; written by my import macro.

With Source_Workbook.Sheets(1)
        .Hyperlinks.Add Anchor:=.Cells(i, 11), _
        Address:=Target_Path, _
        ScreenTip:="Open Excel-bestand met basisgegevens van " & Target_Data, _
        TextToDisplay:=Target_Data
    End With

And then in Column DK and AE (with "temp" instead of username-path) the hyperlink as text, so I can use it again for this Outlook Appointment macro.

Pad = Environ("USERPROFILE")
        
    Link = Blad1.Cells(i, 115).Value
        
    Link = Application.Substitute(Link, Pad, "C:\Users\Temp")
       
    ''Link = Application.Substitute(Link, UserVar, "Temp")
    ''MsgBox Link
         
    Source_Workbook.Sheets(1).Cells(i, 131) = Link

But now I get the created link also in my sheet in A1.