Macro om agenda items op category te verwijderen

[josoetgebrook]

Ik heb een excel-bestand met daarin een macro om agenda-items te exporteren naar de outlook agenda.

Ik gebruik hiervoor een excel-bestand met 5 kolommen:
onderwerp
locatie
data
aanvang
einde

Vervolgens kan ik met de macro alles in mijn agenda zetten.
Deze agende-items hebben ook een automatisch een categorie.

Soms zijn er wijzigingen, maar als ik dan opnieuw zou exporteren, krijg ik alle niet gewijzigde items dubbel erin te staan en de gewijzigde items staan met de oude datum en nieuwe datum in mijn agenda.

Dit kan ik oplossen door in de agenda steeds te sorteren op categorie en vervolgens alle items van die categorie weg te gooien voordat ik opnieuw importeer.

Ik vroeg me af of het ook mogelijk is om dit met een macro op te lossen is.

Kan iemand me daarbij helpen?

Ik weet bijvoorbeeld al niet hoe ik in een macro agenda-items op categorie kan selecteren.

[Witte]

Je moet iedere afspraak voorzien van een uniek nummer, dat je ergens in Outlook mee opslaat.
Wijzigt een afspraak, ga je in Outlook op zoek naar dat nummer en kan je de gegevens wijzigen. Komt een nummer in Oulook niet voor ==> nieuwe afspraak en toevoegen dus.

(ik heb in VBA ooit een tooltje gemaakt om contactpersonen naar mijn Oulook te verplaatsen. Dan wil je ook niet voortdurend dubbele hebben )

[ Voor 21% gewijzigd door Witte op 15-09-2011 08:00 ]

[josoetgebrook]

Dat zou een goede oplossing zijn als ik alle agenda-items handmatig in Excel zou invoeren.

Het gaat hierbij om behoorlijk veel gegevens die ik met de functie "Externe gegevens ophalen van web" kan importeren.

Probleem is dat meer mensen dit bestand zouden moeten gaan gebruiken en deze gegevens per gebruiker verschillend zijn.

Het nummeren van afspraken heeft dus geen nut, omdat tijdens de import de oude lijst wordt overschreven.

[Witte]

Hoe verwacht je dan dat Outlook (of Excel) 'ziet' dat afspraken er al in staan, notabene met een andere datum en tijd? Er moet een unieke link zijn.

Of je gebruikt de Outlook identifier van een afspraak, of je zorgt dat elke afspraak in Excel een uniek nummer krijgt.

[wens]

Met wat leeswerk van diverse voorbeelden op internet heb ik zelf ook zo'n macro gemaakt.
We hebben een planning met meerdere personen die in meerdere kolommen staan.
En die planning moest naar Exchange/Outlook.

Mijn macro doet volgende:
1) kijk voor wie er iets gedaan moeten worden
2) kijk voor welke week er iets geplaatst moet worden
3) doorloop de dagen van deze week en:
3a) maak een array van afspraken op die dag
3b) verwijder afspraken met een specifieke categorie
3c) plaats nieuwe afspraken met specifieke categorie

Stuur maar even een DM voor een stukje source.

[josoetgebrook]

Sorry, wat bedoel je met DM?

[RaZ]

Direct Messages in andere software heet dat Private Messages.

Dat moet je dus even aanzetten: http://gathering.tweakers.net/forum/preferences

[F_J_K]

Direct message (knopje bij elke naam, mits je zelf DM's aan hebt staan in je http://gathering.tweakers.net/forum/preferences). (edit: ik ben iets te traag)

Maar: code etc. graag gewoon in het topic, dan kunnen anderen er ook van leren

Overigens zou je er met alleen dit beetje pseudo-code al een heel eind zelf moeten kunnen komen. En als je geen kaas hebt gegegen van VA (en het ook niet eerst goed wil leren) dan weet ik niet of het verstandig is om code aan door anderen te laten gebruiken...

--

Bomen <==> bos: kan je niet beter 'gewoon' een gedeelde agenda gebruiken zoals bijv. via Google agenda?

[ Voor 3% gewijzigd door F_J_K op 15-09-2011 12:32 ]

[josoetgebrook]

Bedankt voor de uitleg, ik heb de optie aangezet.

Google Agenda is geen optie, daarmee kan ik niet vanuit excel agenda-items exporteren naar outlook.

[Roady81]

Om alle afspraken met een bepaalde categorie te krijgen kun je hetvolgende doen;
(dit voorbeeld geeft als output een messagebox voor iedere afspraak met de categorie "Test")

Visual Basic:

Sub FindAppointmentsByCategory()
    'Declarations
    Dim Filter As String
    Dim oRow As Outlook.Row
    Dim oTable As Outlook.Table
    Dim oFolder As Outlook.Folder
    Dim strSearch As String
    
    'Search string
    strSearch = "Test"

    'Get a Folder object for the Calendar
    Set oFolder = Application.Session.GetDefaultFolder(olFolderCalendar)

    'Define Filter to obtain items with Category "Test"
    Filter = "[Categories] = '" & strSearch & "'"
    'Restrict with Filter
    Set oTable = oFolder.GetTable(Filter)

    'Enumerate the table using test for EndOfTable
    Do Until (oTable.EndOfTable)
        Set oRow = oTable.GetNextRow()
        MsgBox (oRow("Subject"))
    Loop
End Sub

[josoetgebrook]

Ik heb het bestand op dropbox gezet.

http://dl.dropbox.com/u/4193400/agenda_export_outlook.xlsm

Zoals je ziet worden de afspraken allemaal opgeslagen met de categorie Vergaderingen.

Ik zou graag willen dat ik via een macro de volledige categorie kan verwijderen, voordat ik de vergaderingen opnieuw exporteer, omdat er wijzigingen plaats kunnen vinden.

Als ik dit niet doe, krijg ik dubbele afspraken en afspraken op oude en nieuwe momenten, dat maakt het ook niet overzichtelijk.

[wens]

Maar: code etc. graag gewoon in het topic, dan kunnen anderen er ook van leren

OK

Mogelijk kan mijn code makkelijker en/of mooier, maar het werkt
Er staat hier en daar ook nog wat commentaar, volgens mij moet het leesbaar zijn

Visual Basic:

Sub VulAgenda(myColumns, myWeeks)
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim rowCount As Integer
    Dim myStringPos As Integer
    
    Dim myStartColumn As Integer
    Dim myEndColumn As Integer
        
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim blnCreated As Boolean
    
    Dim daStart, daEnd As Date
    Dim oCalendar As Outlook.Folder
    Dim oItems As Outlook.Items
    Dim oItemsInDateRange As Outlook.Items
    Dim oFinalItems As Outlook.Items
    Dim oAppt As Outlook.AppointmentItem
    Dim strRestriction As String
    
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.Recipient
    Dim myRecipientName As String
    
    Dim myRowPosition As Integer
    
    On Error GoTo Errhandler
    
    'Check how many columns should be processed
    If myColumns = 0 Then
        'Process all columns
        myStartColumn = 8   '1e persoon, kolom H
        myEndColumn = 24   'laatste persoon kolom X
    Else
        'Process only selected column
        myStartColumn = myColumns
        myEndColumn = myColumns
    End If
    
    'Check how many weeks should be processed
    'And set start position of weeks to be processed
    If myWeeks = 1 Then
        j = ActiveCell.Row
        For i = j - 10 To j
            If Left(Cells(i, 1).Value, 4) = "Week" Then
                myRowPosition = i
            End If
        Next i
        'Debug.Print myRowPosition
    Else
        j = 5
        Do
        j = j + 1
        If j > 700 Then
            Exit Do
        End If
        Loop Until Date = Cells(j, 1)
        For i = j - 10 To j
            If Left(Cells(i, 1).Value, 4) = "Week" Then
                myRowPosition = i
            End If
        Next i
        'Debug.Print myRowPosition
    End If
    
    For j = myStartColumn To myEndColumn
      Debug.Print "Person to process: " & Cells(6, j).Value
      'Get correct name, also when charachter ( is present
      For myStringPos = 1 To Len(Cells(6, j))
        If Mid(Cells(6, j).Value, myStringPos, 1) = "(" Then
            myRecipientName = Left(Cells(6, j).Value, myStringPos - 2)
            myStringPos = Len(Cells(6, j))
        Else
            myRecipientName = Cells(6, j).Value
        End If
      Next myStringPos
      Debug.Print myRecipientName
      
      Set olApp = GetObject(, "Outlook.Application")
      If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        blnCreated = True
        Err.Clear
      Else
        blnCreated = False
      End If

      Set myNamespace = olApp.GetNamespace("MAPI")
      Set myRecipient = myNamespace.CreateRecipient(myRecipientName)
      myRecipient.Resolve
      If myRecipient.Resolved Then
      
        For i = 1 To (10 * myWeeks + myWeeks)
          If Cells(myRowPosition + i, 1).Value <> "" And Left(Cells(myRowPosition + i, 1).Value, 4) <> "Week" Then
            Debug.Print "Date to process:           " & Cells(myRowPosition + i, 1).Value
            'Debug.Print "Lets delete appointments, if present"
            'Construct a filter for the appointment to be removed
            strRestriction = "[Start] >= '" & Cells(myRowPosition + i, 1).Value & " 00:00' AND [End] <= '" & Cells(myRowPosition + i, 1).Value & " 23:59'"
            'Debug.Print strRestriction
            
            'Set oCalendar = Session.GetDefaultFolder(olFolderCalendar)
            Set oCalendar = Session.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
            Set oItems = oCalendar.Items
            
            oItems.IncludeRecurrences = False
            oItems.Sort "[Start]"
            
            ' Restrict the Items collection for the filter.
            Set oItemsInDateRange = oItems.Restrict(strRestriction)
            
            'Debug.Print oItems.Count
            'Debug.Print oItemsInDateRange.Count
            
            'Delete Appointment with correct Category
            For rowCount = oItemsInDateRange.Count To 1 Step -1
                If TypeName(oItemsInDateRange(rowCount)) = "AppointmentItem" Then
                    'Debug.Print "                  " & rowCount, oItemsInDateRange(rowCount).Start, oItemsInDateRange(rowCount).End, oItemsInDateRange(rowCount).Subject
                    If InStr(1, oItemsInDateRange(rowCount).Categories, "Created by Excel Planning", vbTextCompare) = 1 Then
                        Debug.Print "Te verwijderen:   " & rowCount, oItemsInDateRange(rowCount).Start, oItemsInDateRange(rowCount).End, oItemsInDateRange(rowCount).Subject
                        oItemsInDateRange(rowCount).Delete
                    End If
                End If
            Next rowCount
            
            'Let's create new appointments
             If Cells(myRowPosition + i, j).Value <> "" Then
                Debug.Print "Planned all day activity:  " & Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                
                Set olApt = oCalendar.Items.Add(Outlook.OlItemType.olAppointmentItem)
                  With olApt
                    .Start = Cells(myRowPosition + i, 1).Value + (1 / 24 * 8)
                    .End = Cells(myRowPosition + i, 1).Value + (1 / 24 * 17)
                    Select Case Cells(myRowPosition + i, j).Interior.ColorIndex
                        Case 3
                            If Cells(myRowPosition + i, j).Value = "Helpdesk" Then
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value & " - 8:00"
                            Else
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                            End If
                            .BusyStatus = olBusy
                        Case 38
                            If Cells(myRowPosition + i, j).Value = "Helpdesk" Then
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value & " - 17:00"
                            Else
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                            End If
                            .BusyStatus = olBusy
                        Case 43
                            .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                            .BusyStatus = olOutOfOffice
                        Case 44
                            If Cells(myRowPosition + i, j).Value = "Helpdesk" Then
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value & " - 2e lijns"
                            Else
                                .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                            End If
                            .BusyStatus = olBusy
                        Case Else
                            .Subject = Cells(myRowPosition + i, j).Value & " " & Cells(myRowPosition + i + 1, j).Value
                            .BusyStatus = olBusy
                    End Select
                    .ReminderSet = False
                    .Categories = "Created by Excel planning"
                    If Not Cells(myRowPosition + i, j).Comment Is Nothing And Cells(myRowPosition + i + 1, j).Comment Is Nothing Then
                      .Body = Cells(myRowPosition + i, j).Comment.Text
                    End If
                    If Cells(myRowPosition + i, j).Comment Is Nothing And Not Cells(myRowPosition + i + 1, j).Comment Is Nothing Then
                      .Body = Cells(myRowPosition + i + 1, j).Comment.Text
                    End If
                    If Not Cells(myRowPosition + i, j).Comment Is Nothing And Not Cells(myRowPosition + i + 1, j).Comment Is Nothing Then
                      .Body = Cells(myRowPosition + i, j).Comment.Text & vbLf & vbLf & Cells(myRowPosition + i + 1, j).Comment.Text
                    End If
                    .Save
                  End With
                Set olApt = Nothing
              End If
          
            Set oCalendar = Nothing
            Set oItems = Nothing
            Set oItemsInDateRange = Nothing
            Set oFinalItems = Nothing
            Set olApt = Nothing
            Debug.Print
          End If
        Next i
        
        Set olApp = Nothing
        Set myNamespace = Nothing
        Set myRecipient = Nothing

      Else
        Debug.Print "Geen MAPI"
        'Exit Sub
      End If
      
    Next j
    Exit Sub
    
Errhandler:
    MsgBox "Er gaat iets fout." & vbCr & "Waarschijnlijk geen rechten op Calendar van " & Cells(6, j).Value

End Sub

[josoetgebrook]

Ik heb getracht om dit toe te passen, maar ik krijg steeds foutmeldingen.

Daarom heb ik de code letterlijk gekopieerd, maar dan krijg ik al bij regel 11 een foutmelding met de tekst:
Compileerfout:
Een door de gebruiker gedefinieerd gegevenstype is niet gedefinieerd.

De volgende tekst is geselecteerd:
olApp As Outlook.Application

[ Voor 4% gewijzigd door josoetgebrook op 15-09-2011 14:18 ]

[Roady81]

josoetgebrook schreef op donderdag 15 september 2011 @ 14:09:
Ik heb getracht om dit toe te passen, maar ik krijg steeds foutmeldingen.

Daarom heb ik de code letterlijk gekopieerd, maar dan krijg ik al bij regel 11 een foutmelding met de tekst:
Compileerfout:
Een door de gebruiker gedefinieerd gegevenstype is niet gedefinieerd.

De volgende tekst is geselecteerd:
olApp As Outlook.Application

Aangezien je dit vanuit Excel doet moet je een referentie toevoegen naar Microsoft Outlook xx.x Object Library. In de VBA editor kun je dit doen via Tools-> References...