Niquet.nl

Aanmaken afspraak/meeting in Outlook vanuit Excel

Stappen:

  1. Maak een Excel bestand aan en sla deze op als een Macro enabled workbook, bijv. “Outlouk-agenda vanuit Excel.xlsm”
  2. Maak in eerste tabblad (hernoem deze naar ‘agenda’) op de eerste regel de volgende kolomkoppen aan:
    • Agenda – account
    • Onderwerp
    • Locatie
    • Body
    • Datum
    • start
    • eind
    • Hele dag
    • Categorie

Het ziet er dan als volgt uit:

 

Sub MakenOutlookAfspraak()
    
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim calFld As Outlook.Folder
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
    
    On Error Resume Next
    Worksheets("agenda").Activate
    Set olApp = New Outlook.Application

    On Error GoTo 0
    'Checken of Outlook is geïnstalleerd / beschikbaar is
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = New Outlook.Application
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    r = 2 ' eerste rij waar een afspraak is vastgelegd / moet vastgelegd zijn
    Dim account, onderwerp, Start, Einde, kalender, locatie, omschrijving
    
    
    While Len(Cells(r, 1).Text) <> 0
        account = Cells(r, 1) 
        Set calFld = olNS.Folders(account).Folders("Agenda")
        Set olAppItem = calFld.Items.Add(olAppointmentItem)
            
        With olAppItem
            .Subject = Cells(r, 2) & ", " & Cells(r, 3)
            Start = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
            .Start = Start
            
            Einde = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
            .End = Einde
            .Location = Cells(r, 3)
            .Body = Cells(r, 4)
            .Categories = Cells(r, 9)
            If Cells(r, 8) = "Ja" Then
                .AllDayEvent = True
            Else
                .AllDayEvent = False
            End If
            
            'Evt overige opties:
            '            .ReminderSet = True
            '            .BusyStatus = olFree
            '            '.Attachments.Add ("c:\temp\somefile.msg")
            '            .ReminderSet = True
            '            .BusyStatus = olBusy
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    MsgBox "Done !"
End Sub


 

Maak op de tabblad ‘agenda’ een knop die bovenstaande module/macro activeert en voila …klaar

Leave a Comment