Excel bestand met afspraken naar Outlook Agenda 2010

[Bruggemanmark]

Hallo,

Heb onderstaand bestand in een excel bestand staan welke een aantal taken naar Outlook zet. Echter kun je een takenlijst niet makkelijk delen. Graag zou ik de
bestanden delen naar een gedeelde agenda van Outlook. Welke aanpassingen dien ik in het bestand door te voeren.


Alvast bedankt.

Hieronder de code.


Dim a
Dim T As String
Dim i As Integer
Dim blnOutlookQuit As Boolean
Dim lngRow As Long
Dim objFolder As Object
Dim objNamespace As Object
Dim objOutlook As Object
Dim objTask As Object

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
blnOutlookQuit = True
Set objOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(13)
objFolder.Display 'laat folder zien anders foutmelding door remindertime

With Worksheets(6)
For lngRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
a = .Cells(lngRow, 10).Resize(, 5)
T = ""
For i = 1 To 5
T = T & " " & a(1, i) & vbLf
Next
Set objTask = objOutlook.CreateItem(3)
With objTask
.Subject = CStr(Cells(lngRow, 2).Value)
.StartDate = CDate(Cells(lngRow, 3).Value)
.DueDate = CDate(Cells(lngRow, 4).Value)
.Status = CInt(Cells(lngRow, 5).Value) 'olTaskComplete 2, olTaskDeferred 4, olTaskInProgress 1,olTaskNotStarted 0, olTaskWaiting 3
.Importance = CInt(Cells(lngRow, 6).Value) 'olImportanceHigh 2, olImportanceLow 0, olImportanceNormal 1
.PercentComplete = CInt(Cells(lngRow, 7).Value) '0 ... 100 stuurt mogelijk status
.ReminderSet = CBool(Cells(lngRow, 8).Value) 'true false
.ReminderTime = CDate(Cells(lngRow, 9).Value) 'date and time
.Body = T
.Save
End With
Next
End With

If blnOutlookQuit Then
objOutlook.Quit
End If

Set objTask = Nothing
Set objFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing

End Sub

 

[Bruggemanmark]

Is er ook een code welke de dubbele afspraken er uithaalt.
Het is namelijk een excel sheet welke elke keer wordt aangevuld met nieuwe afspraken.
Anders komen de oude er dubbel in.

 

[snb]

Kun je svp VBA-code tussen code-markeringen (tags) zetten ?

 

[Bruggemanmark]

Beste snb,

Hoe kan ik de VBA code tussen codemarkeringen plaatsen. Ben nieuw op dit forum en ook redelijk nieuw met VBA codes.
Alvast bedankt.

 

[snb]

VBA code selecteren in het edit scherm , het icoon # boven het editscherm aanklikken.
Ga zonodig naar het geavanceerde edit-scherm.

 

[Bruggemanmark]

Hieronder de code, volgens mij nu tussen code markeringen zoals gevraagd.

Dim a
Dim T As String
Dim i As Integer
Dim blnOutlookQuit As Boolean
Dim lngRow As Long
Dim objFolder As Object
Dim objNamespace As Object
Dim objOutlook As Object
Dim objTask As Object

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
blnOutlookQuit = True
Set objOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(13)
objFolder.Display 'laat folder zien anders foutmelding door remindertime

With Worksheets(6)
For lngRow = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
a = .Cells(lngRow, 10).Resize(, 5)
T = ""
For i = 1 To 5
T = T & " " & a(1, i) & vbLf
Next
Set objTask = objOutlook.CreateItem(3)
With objTask
.Subject = CStr(Cells(lngRow, 2).Value)
.StartDate = CDate(Cells(lngRow, 3).Value)
.DueDate = CDate(Cells(lngRow, 4).Value)
.Status = CInt(Cells(lngRow, 5).Value) 'olTaskComplete 2, olTaskDeferred 4, olTaskInProgress 1,olTaskNotStarted 0, olTaskWaiting 3
.Importance = CInt(Cells(lngRow, 6).Value) 'olImportanceHigh 2, olImportanceLow 0, olImportanceNormal 1
.PercentComplete = CInt(Cells(lngRow, 7).Value) '0 ... 100 stuurt mogelijk status
.ReminderSet = CBool(Cells(lngRow, 8).Value) 'true false
.ReminderTime = CDate(Cells(lngRow, 9).Value) 'date and time
.Body = T
.Save
End With
Next
End With

If blnOutlookQuit Then
objOutlook.Quit
End If

Set objTask = Nothing
Set objFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing

End Sub

 

[snb]

Mij lijkt getdefaultfolder(13) niet de gemeenschappelijke agenda.
Die zul je dus door de map van de gemeenschappelijke agenda moeten vervangen.

En het kan met wel wat minder objectvariabelen als je slim gebruik maakt van With ... End With

Zie ook:

http://www.snb-vba.eu/VBA_Outlook_external.html#H12

 

[Bruggemanmark]

Hallo SNB,

Ben nog niet zo ver dat mij het lezen en maken van de codes lukt welke je via de link aangaf.

Heb inmiddels van mijn ingestuurde codes wel de map aangepast naar 9. Maar wat dien ik nog
meer aan te passen. Want de herinnering komt nog steeds in de taken terecht.

Welke codes moet ik veranderen/ aanpassen.

Graag zou ik ook een code hebben voor de dubbele afspraken te verwijderen.