hyperlink kopiëren naar outlook agenda

[Dozo2000]

Hallo,

Ik heb een bestand, waarin ik dmv een macro andere bestanden inlees.
Deze bestandsnamen komen in een cel met hyperlink, waardoor je met één klik naar het bronbestand kunt.
Dit werkt allemaal prima.

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

Echter...
Ik maak ook automatisch herinneringen die dan geplaatst worden in de Outlook agenda, met daarin alle relevante data.

Dit werkt ook prima, maar ik wil graag ook de hyperlink plaatsen, zodat je direct vanuit Outlook het bestand kunt openen, mocht je alle informatie willen hebben.

 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 = "Bellen met " & Blad1.Cells(r, 15).Value & " over offerte (" & Blad1.Cells(r, 3).Value & ")." & vbNewLine & vbNewLine & "Betreffende " & Blad1.Cells(r, 23).Value & "." & vbNewLine & vbNewLine & vbNewLine & Blad1.Cells(r, 11).Value & " - " & Blad1.Cells(r, 22).Value & vbNewLine & vbNewLine & vbNewLine & Blad1.Cells(r, 11).Value & vbNewLine & Blad1.Cells(r, 12).Value & vbNewLine & Blad1.Cells(r, 13).Value & " " & Blad1.Cells(r, 14).Value & vbNewLine & vbNewLine & Blad1.Cells(r, 15).Value & vbNewLine & Blad1.Cells(r, 16).Value & vbNewLine & Blad1.Cells(r, 105).Value & vbNewLine & Blad1.Cells(r, 115).Value & vbNewLine & Blad1.Cells(r, 125).Value
              
             
        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

En dat krijg ik dus niet voor elkaar... Heb al uren gegoogled...

Is zoiets mogelijk?

 

[edmoor]

Ik heb dat nog nooit gedaan, maar voor een email zou je dan werken met HTMLBody in plaats van Body. Wellicht dat dat met een agenda item ook zo is.

 

[Dozo2000]

Als ik HTMLBody gebruik, dan blijft de body leeg.

Het probleem zit in het op de juiste manier verkrijgen van de hyperlinks denk ik.

Maar bedankt voor de moeite!

 

[edmoor]

Je laat niet zien wat je nu precies doet voor het maken van het agenda item.
Het zal toch in HTML moeten, anders krijg je er geen hyperlink in.
Uiteraard moet je in je VBA code de hyperlink helemaal zelf opbouwen in HTML code.

 

[Dozo2000]

Bedoel je welke regels ik gebruik in de macro voor het maken van de afspraak?
Hieronder het gedeelte uit de code:

Private Sub RobbinJan_Click()
    Mystring = "RJH"
    sVW = "Robbin Jan"
    Keuzes.Hide
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    bOLOpen = True
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    Set NS = OL.GetNamespace("MAPI")
    Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
     
     
    For r = 4 To 220
        
         
        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 = "Bellen met " & Blad1.Cells(r, 15).Value & " over offerte (" & Blad1.Cells(r, 3).Value & ")." & vbNewLine & vbNewLine & "Betreffende " & Blad1.Cells(r, 23).Value & "." & vbNewLine & vbNewLine & vbNewLine & Blad1.Cells(r, 11).Value & " - " & Blad1.Cells(r, 22).Value & vbNewLine & vbNewLine & vbNewLine & Blad1.Cells(r, 11).Value & vbNewLine & Blad1.Cells(r, 12).Value & vbNewLine & Blad1.Cells(r, 13).Value & " " & Blad1.Cells(r, 14).Value & vbNewLine & vbNewLine & Blad1.Cells(r, 15).Value & vbNewLine & Blad1.Cells(r, 16).Value
              
             
        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"
         
        If dStartTime > Date Then
        If sName = Mystring Then
         
        sSearch = "[Subject] = " & sQuote(sSubject)
        Set olApptSearch = colItems.Find(sSearch)
        
                 
        If olApptSearch Is Nothing Then
            Set olAppt = OL.CreateItem(olAppointmentItem)
            olAppt.Body = sBody
            olAppt.Subject = sSubject
            olAppt.Start = dStartTime
            olAppt.End = dEndTime
            olAppt.ReminderMinutesBeforeStart = dReminder
            olAppt.Location = sLocation
            olAppt.Categories = dCatagory
            olAppt.Close olSave
        End If
        
        End If
        End If
NextRow:
    Next r
     
     
    If bOLOpen = False Then OL.Quit
    MsgBox "Reminders voor " + sVW + " aangemaakt in Outlook agenda...", vbMsgBoxSetForeground
    Unload Keuzes
End Sub

 

[Dozo2000]

Ik heb het naar onderstaande code aangepast en krijg dan wel een klikbare link.

Er komt C:/directorie/filename.xlsx ; maar ik mis nog het gedeelte "users/Dozo/Documents and settings/"

Ik weet niet of hier een oplossing voor is...

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"