Appointments from Excel to Outlook

[cloosen]

Hi Kenners! :thumb:

Hopelijk kan iemand me nog een beetje op weg helpen. Onderstaande VBA code heb ik gemaakt (en die werkt al :thumb om m.b.v. de data in de kolommen A t/m D afspraken in Outlook automatisch aan te maken.

Wat ik graag wil is alvorens de afspraken in Outlook te controleren of de afspraak wellicht al bestaat in Outlook. Mocht het zo zijn dat op een bepaalde startdatum (kolom A) het onderwerp al bestaat (kolom D) dan zou die afspraak geupdate moeten worden i.p.v. nog een keer toegevoegd te worden. Kan iemand mij hierin op weg helpen, ik heb me al rotgegooled namelijk... Many, many thanks!!

Hierbij de VBA die ik al heb (wellicht ook handig voor andere):

Sub ScheduleAppts()
Dim ol As New Outlook.Application
Dim ns As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim appt As Outlook.AppointmentItem
Dim R As Integer
Dim X As Integer

R = Range("A10").End(xlUp).Row

Set ns = ol.GetNamespace("MAPI")
Set olFolder = ns.GetDefaultFolder(olFolderCalendar)

For X = 2 To R
Set appt = olFolder.Items.Add
With appt
.Start = Sheets("Sheet1").Cells(X, 1).Value
.End = Sheets("Sheet1").Cells(X, 2).Value
.Location = Sheets("Sheet1").Cells(X, 3).Value
.Subject = Sheets("Sheet1").Cells(X, 4).Value
.Body = "Afspraak automatisch geplaatst."
.BusyStatus = olOutOfOffice
.ReminderMinutesBeforeStart = 30
.ReminderSet = True
.Save
End With
Next X

Set ol = Nothing
Set ns = Nothing
Set appt = Nothing
End Sub

 

[Finch]

Hieronder wat code dat kijkt naar de startdatum op cel A1 van sheet 2 en het onderwerp in cel D1 van sheet 2. Wanneer deze gegevens niet bestaan in de Outlook kalender gebeurt er niks, in het andere geval wordt het onderwerp aangepast naar de stringwaarde "test".

Dim sFind As String
sFind = "[Start] = '" & Format(Sheets(2).Cells(1, 1), "ddddd h:mm") & "' AND [Subject]='" & Sheets(2).Cells(1, 4) & "'"

Set appt = olFolder.Items.Find(sFind)

If Not appt Is Nothing Then
    appt.Subject = "test"
    appt.Save
End If

Aan u om dit te integreren in je code (dus een update bij een match en een nieuw record bij geen match). Moest je er nog niet uitkomen, laat het dan weten.

 

[cloosen]

Super thnx alvast! :thumb:

Ik ga hiermee even klussen, ik hou jullie op de hoogte (voor de geinteresseerde: hierbij alvast de code waarmee ik items in een shared calendar plaats ):

Sub ScheduleAppts()
Dim ol As New Outlook.Application
Dim ns As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim appt As Outlook.AppointmentItem
Dim myRecipient As Outlook.Recipient
Dim R As Integer
Dim X As Integer

R = Range("A10").End(xlUp).Row

Set ns = ol.GetNamespace("MAPI")

'Onderstaand voor eigen default folder
'Set olFolder = ns.GetDefaultFolder(olFolderCalendar)

Set ol = CreateObject("Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set myRecipient = ns.CreateRecipient(" [I]naam van de shared person [/I] ")
myRecipient.Resolve
Set olFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderCalendar)

For X = 2 To R
Set appt = olFolder.Items.Add
With appt
.Start = Sheets("Sheet1").Cells(X, 1).Value
.End = Sheets("Sheet1").Cells(X, 2).Value
.Location = Sheets("Sheet1").Cells(X, 3).Value
.Subject = Sheets("Sheet1").Cells(X, 4).Value
.Body = "Afspraak automatisch geplaatst."
.BusyStatus = olOutOfOffice
.ReminderMinutesBeforeStart = 30
.ReminderSet = True
.Save
End With
Next X

Set ol = Nothing
Set ns = Nothing
Set appt = Nothing
End Sub

 

[cloosen]

Lukt toch niet helemaal...

Hi Finch (e.a.)... Het lukt me toch niet helemaal om dit er in te klussen (omdat ik niet naar A1 moet kijken, maar over de rijen van kolom A moet lussen)... Ik heb nu onderstaande code, zou jij (of iemand) nog eens een blikje willen wagen en me kunnen hinten..? Many, many thanks again! :thumb:

Sub ScheduleAppts()
Dim ol As New Outlook.Application
Dim ns As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim appt As Outlook.AppointmentItem
Dim myRecipient As Outlook.Recipient
Dim R As Integer
Dim X As Integer
Dim sFind As String

R = Range("A10").End(xlUp).Row

Set ns = ol.GetNamespace("MAPI")

'Onderstaand voor eigen default folder
'Set olFolder = ns.GetDefaultFolder(olFolderCalendar)

Set ol = CreateObject("Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set myRecipient = ns.CreateRecipient(" [I]Name[/I] ")
myRecipient.Resolve
Set olFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderCalendar)

For X = 2 To R
sFind = "[Start] = '" & Format(Sheets("Sheet1").Cells(X, 1), "ddddd h:mm")
Set appt = olFolder.Items.Find(sFind)

If Not appt Is Nothing Then
appt.End = Sheets("Sheet1").Cells(X, 2).Value
appt.Location = Sheets("Sheet1").Cells(X, 3).Value
appt.Save
Else
Set appt = olFolder.Items.Add
With appt
.Start = Sheets("Sheet1").Cells(X, 1).Value
.End = Sheets("Sheet1").Cells(X, 2).Value
.Location = Sheets("Sheet1").Cells(X, 3).Value
.Subject = Sheets("Sheet1").Cells(X, 4).Value
.Body = "Afspraak automatisch geplaatst."
.BusyStatus = olOutOfOffice
.ReminderMinutesBeforeStart = 30
.ReminderSet = True
.Save
End With
End If
Next X

Set ol = Nothing
Set ns = Nothing
Set appt = Nothing
End Sub

 

[Wigi]

cloosen, kan je aub in je posts eens code tags plaatsen? Zie http://www.helpmij.nl/forum/showthread.php?t=278887

Dan komt de code netjes over in een venster.

 

[Finch]

Je doet alleen maar een Find op beginuur, niet op onderwerp. De syntax van je sfind string is ook niet correct (goed opletten met ' en "). Wat is het juist dat er niet werkt?

 

[cloosen]

Wat zijn jullie snel mannen!! :thumb:

Wigi: code tags toegevoegd! Excuus hiervoor...

Om te proberen wilde ik eerst alleen de check doen op kolom A (vandaar dat ik kolom D niet meenam)... De rest van de code had ik gekopieerd vanuit hier, wellicht dat dat niet helemaal goed is gegaan dan...

Verder denk ik dat ik de sFind op een verkeerde plek hebt gezet, de foutmelding: "out of memory" (nested loop maybe??) krijg ik.

Ik ga zo even naar huis rijden (ca 1 1/2 uur) en ga vanavond weer klussen! Dank, dank!

 

[Finch]

Wat zijn jullie snel mannen!! :thumb:

Om te proberen wilde ik eerst alleen de check doen op kolom A (vandaar dat ik kolom D niet meenam)... De rest van de code had ik gekopieerd vanuit hier, wellicht dat dat niet helemaal goed is gegaan dan...

Daardoor is je Sfind string niet correct. Probeer even de versie die ik postte (aangepast aan jouw kolommen).