Outlook Agenda vullen vanuit excel

Status
Niet open voor verdere reacties.
T

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Onderstaande macro gebruik ik om een outlook agenda te vullen alleen loop ik tegen het volgende aan.
De gefilterde/verborgen regels worden nu niet overgeslagen. Hoe kan ik dat oplossen

Code: 
Sub Export1()
    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.MAPIFolder
    Dim I As Long
    Dim xRg As Range
    Dim xOutItem As Object



    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set olFolder = olApp.GetNamespace("MAPI").PickFolder
    
    If olFolder Is Nothing Then
    GoTo ErrorHandler:
    End If

    
    Set xRg = ActiveSheet.Range("A2:M" & ActiveSheet.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)

    
    
[COLOR="#B22222"]    For I = 1 To xRg.Rows.Count[/COLOR]
  
  
        Set xOutItem = olFolder.Items.Add
        Debug.Print xRg.Cells(I, 1).Value
        xOutItem.Subject = xRg.Cells(I, 1).Value
        
        xOutItem.Start = xRg.Cells(I, 2).Value + xRg.Cells(I, 3).Value
        xOutItem.End = xRg.Cells(I, 4).Value + xRg.Cells(I, 5).Value
        
        If xRg.Cells(I, 6).Value = "Ja" Then
        xOutItem.AllDayEvent = True
        Else
        xOutItem.AllDayEvent = False
        End If
        
        
        If xRg.Cells(I, 7).Value = "Geen" Then
        xOutItem.ReminderSet = False
        ElseIf xRg.Cells(I, 7).Value = "0 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 0
        ElseIf xRg.Cells(I, 7).Value = "5 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 5
        ElseIf xRg.Cells(I, 7).Value = "10 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 10
        ElseIf xRg.Cells(I, 7).Value = "15 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 15
        ElseIf xRg.Cells(I, 7).Value = "30 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 30
        ElseIf xRg.Cells(I, 7).Value = "1 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 60
        ElseIf xRg.Cells(I, 7).Value = "2 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 120
        ElseIf xRg.Cells(I, 7).Value = "3 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 180
        ElseIf xRg.Cells(I, 7).Value = "4 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 240
        ElseIf xRg.Cells(I, 7).Value = "5 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 300
        ElseIf xRg.Cells(I, 7).Value = "6 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 360
        ElseIf xRg.Cells(I, 7).Value = "7 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 420
        ElseIf xRg.Cells(I, 7).Value = "8 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 480
        ElseIf xRg.Cells(I, 7).Value = "9 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 540
        ElseIf xRg.Cells(I, 7).Value = "10 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 600
        ElseIf xRg.Cells(I, 7).Value = "11 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 660
        ElseIf xRg.Cells(I, 7).Value = "0" & Chr(130) & "5 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 720
        ElseIf xRg.Cells(I, 7).Value = "18 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 1080
        ElseIf xRg.Cells(I, 7).Value = "1 dag" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 1440
        ElseIf xRg.Cells(I, 7).Value = "2 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 2880
        ElseIf xRg.Cells(I, 7).Value = "3 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 5760
        ElseIf xRg.Cells(I, 7).Value = "4 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 11520
        ElseIf xRg.Cells(I, 7).Value = "1 week" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 10080
        ElseIf xRg.Cells(I, 7).Value = "2 weken" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 20160
        End If

        xOutItem.Body = xRg.Cells(I, 8).Value
        xOutItem.Categories = xRg.Cells(I, 9).Value
        xOutItem.Location = xRg.Cells(I, 10).Value
          
        If xRg.Cells(I, 11).Value = "Lage urgentie" Then
        xOutItem.Importance = olImportanceLow '0 - Lage urgentie
        ElseIf xRg.Cells(I, 11).Value = "" Then
        xOutItem.Importance = olImportanceNormal '1 - Normale urgentie
        ElseIf xRg.Cells(I, 11).Value = "Hoge urgentie" Then
        xOutItem.Importance = olImportanceHigh '2 - Hoge urgentie
        End If
        
        If xRg.Cells(I, 12).Value = "" Then
        xOutItem.Sensitivity = olNormal '0 - Normal sensitivity
        ElseIf xRg.Cells(I, 12).Value = "Personal" Then
        xOutItem.Sensitivity = olPersonal '1 - Personal
        ElseIf xRg.Cells(I, 12).Value = "Private" Then
        xOutItem.Sensitivity = olPrivate '2 - Private
        ElseIf xRg.Cells(I, 12).Value = "Confidential" Then
        xOutItem.Sensitivity = olConfidential '3 - Confidential
        End If
          
      
        If xRg.Cells(I, 13).Value = "Vrij" Then
        xOutItem.BusyStatus = olFree '0 - Vrij
        ElseIf xRg.Cells(I, 13).Value = "Voorlopig bezet" Then
        xOutItem.BusyStatus = olTentative '1 - Voorlopig bezet
        ElseIf xRg.Cells(I, 13).Value = "Bezet" Then
        xOutItem.BusyStatus = olBusy '2 - Bezet
        ElseIf xRg.Cells(I, 13).Value = "Niet aanwezig" Then
        xOutItem.BusyStatus = olOutOfOffice '3 - Niet aanwezig
        ElseIf xRg.Cells(I, 13).Value = "Elders werkend" Then
        xOutItem.BusyStatus = olWorkingElsewhere '4 - Elders werkend
        End If

        xOutItem.Save
        Set xOutItem = Nothing
        
            
    Next
    
ErrorHandler:

    Set olApp = Nothing
    Set olFolder = Nothing
    Set xRg = Nothing
    Set xOutItem = Nothing

    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

mvg
Kasper
 
Controleer of de regel verborgen is voor je er iets mee doet:
If xRg.Rows(I).Hidden = False Then
 
Lijkt mij wel onzinnig veel regels code.

Code: 
If xRg.Cells(I, 7).Value = "Geen" Then
        xOutItem.ReminderSet = False
        ElseIf xRg.Cells(I, 7).Value = "0 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 0
        ElseIf xRg.Cells(I, 7).Value = "5 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 5
        ElseIf xRg.Cells(I, 7).Value = "10 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 10
        ElseIf xRg.Cells(I, 7).Value = "15 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 15
        ElseIf xRg.Cells(I, 7).Value = "30 minuten" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 30
        ElseIf xRg.Cells(I, 7).Value = "1 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 60
        ElseIf xRg.Cells(I, 7).Value = "2 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 120
        ElseIf xRg.Cells(I, 7).Value = "3 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 180
        ElseIf xRg.Cells(I, 7).Value = "4 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 240
        ElseIf xRg.Cells(I, 7).Value = "5 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 300
        ElseIf xRg.Cells(I, 7).Value = "6 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 360
        ElseIf xRg.Cells(I, 7).Value = "7 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 420
        ElseIf xRg.Cells(I, 7).Value = "8 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 480
        ElseIf xRg.Cells(I, 7).Value = "9 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 540
        ElseIf xRg.Cells(I, 7).Value = "10 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 600
        ElseIf xRg.Cells(I, 7).Value = "11 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 660
        ElseIf xRg.Cells(I, 7).Value = "0" & Chr(130) & "5 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 720
        ElseIf xRg.Cells(I, 7).Value = "18 uur" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 1080
        ElseIf xRg.Cells(I, 7).Value = "1 dag" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 1440
        ElseIf xRg.Cells(I, 7).Value = "2 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 2880
        ElseIf xRg.Cells(I, 7).Value = "3 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 5760
        ElseIf xRg.Cells(I, 7).Value = "4 dagen" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 11520
        ElseIf xRg.Cells(I, 7).Value = "1 week" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 10080
        ElseIf xRg.Cells(I, 7).Value = "2 weken" Then
        xOutItem.ReminderSet = True
        xOutItem.ReminderMinutesBeforeStart = 20160
        End If

Kan ook zoiets worden (alleen even voor de reminder en zonder rekening te houden met de verborgen rijen en met de afwijkingen die je hebt bij 3 of 4 dagen)
Code: 
Sub VenA()
  ar = Sheets("Sheet1").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    ar1 = Split(ar(j, 7))
    If UBound(ar1) > 0 Then
      c00 = Left(ar1(1), 2)
      t = Replace(ar1(0), Chr(130), ".")
      Debug.Print Abs(t * ((c00 = "mi") + 60 * ((c00 = "uu") + 24 * ((c00 = "da") + 7 * (c00 = "we")))))
    End If
  Next j
End Sub

De rest kan allemaal ook veel eenvoudiger. Kijk eens naar de select case methode.
 
Ik heb de ElseIf functie vervangen door Select Case functie. Dezen werken volgens mij goed.
Ik heb geprobeerd de macro van VenA te gebruiken alleen kom ik daar niet uit.
Bij "geen" is de ReminderSet = False en ReminderMinutesBeforeStart wordt dan niet gebruikt.
Bij de andere varianten is de ReminderSet = True en ReminderMinutesBeforeStart = (minuten)
Daarnaast loop de macro vast als ik regel 3 en 4 eruit filtert.

In de module import staat het andersom.

Voorbeeld
 

Bijlagen

  • Outlook agenda Import-Export.xlsm
    46,9 KB · Weergaven: 33
Natuurlijk doet mijn code niets. Het was alleen een voorzet om jouw code te vereenvoudigen. Al eens wat debug methodes gebruikt? Debug.print zet de resultaten in het interemediate venster en kan je dus snel zien of de verwachte uitkomt goed is.
Was in mijn geval niet goed.
Code: 
t = Replace(ar1(0), Chr(130), "[COLOR="#FF0000"].[/COLOR]")
Moet
Code: 
t = Replace(ar1(0), Chr(130), "[COLOR="#FF0000"],[/COLOR]")



De Select Case heb ik niet getest maar het maakt jouw code een stuk leesbaarder.
 

Bijlagen

  • Tweety1.JPG
    Tweety1.JPG
    62,4 KB · Weergaven: 46
Ik heb de macro aangepast en het werkt.
De macro loopt alleen nog vast als ik regel 3 en 4 eruit filtert.

Code: 
Sub Export1()
    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.MAPIFolder
    Dim I As Long
    Dim xRg As Range
    Dim xOutItem As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set olFolder = olApp.GetNamespace("MAPI").PickFolder
    
    If olFolder Is Nothing Then
    GoTo ErrorHandler:
    End If

    
    Set xRg = ActiveSheet.Range("A2:M" & ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)

    For I = 1 To xRg.Rows.Count
  
    If xRg.Rows(I).Hidden = False Then
  
        Set xOutItem = olFolder.Items.Add
        Debug.Print xRg.Cells(I, 1).Value
        xOutItem.Subject = xRg.Cells(I, 1).Value
        
        xOutItem.Start = xRg.Cells(I, 2).Value + xRg.Cells(I, 3).Value
        xOutItem.End = xRg.Cells(I, 4).Value + xRg.Cells(I, 5).Value
        

        If xRg.Cells(I, 7).Value = "Geen" Then
        
        xOutItem.ReminderSet = False
        
        Else
        
            ar1 = Split(xRg(I, 7))
            If UBound(ar1) > 0 Then
            xOutItem.ReminderSet = True
            c00 = Left(ar1(1), 2)
            t = Replace(ar1(0), Chr(130), ",")
            xOutItem.ReminderMinutesBeforeStart = Abs(t * ((c00 = "mi") + 60 * ((c00 = "uu") + 24 * ((c00 = "da") + 7 * (c00 = "we")))))
            End If
        
        End If

        xOutItem.Body = xRg.Cells(I, 8).Value
        xOutItem.Categories = xRg.Cells(I, 9).Value
        xOutItem.Location = xRg.Cells(I, 10).Value

        Select Case xRg.Cells(I, 11).Value
          Case "Lage urgentie"
                xOutItem.Importance = olImportanceLow  '0 - Lage urgentie
          Case ""
                xOutItem.Importance = olImportanceNormal  '1 - Normale urgentie
          Case "Hoge urgentie"
                xOutItem.Importance = olImportanceHigh  '2 - Hoge urgentie
        End Select
        
        Select Case xRg.Cells(I, 12).Value
          Case ""
                xOutItem.Sensitivity = olNormal '0 - Normale gevoeligheid
          Case "Ja"
                xOutItem.Sensitivity = olPrivate '2 - Privé
        End Select
        
        Select Case xRg.Cells(I, 13).Value
          Case "Vrij"
                xOutItem.BusyStatus = olFree '0 - Vrij
          Case "Voorlopig bezet"
                xOutItem.BusyStatus = olTentative '1 - Voorlopig bezet
          Case "Bezet"
                xOutItem.BusyStatus = olBusy '2 - Bezet
          Case "Niet aanwezig"
                xOutItem.BusyStatus = olOutOfOffice '3 - Niet aanwezig
          Case "Elders werkend"
                xOutItem.BusyStatus = olWorkingElsewhere '4 - Elders werkend
        End Select
        
        Select Case xRg.Cells(I, 6).Value
          Case "Ja"
                xOutItem.AllDayEvent = True
                xOutItem.BusyStatus = olFree '0 - Vrij
                xOutItem.ReminderSet = False
          Case ""
                xOutItem.AllDayEvent = False
        End Select
        
        xOutItem.Save
        Set xOutItem = Nothing
       End If
            
    Next
    
ErrorHandler:

    Set olApp = Nothing
    Set olFolder = Nothing
    Set xRg = Nothing
    Set xOutItem = Nothing

    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

In de module import heb ik ook een If/ElseIf functie staan kan deze ook met minder regels of kan je deze beter omzetten naar select case methode?

Code: 
       If olApt.ReminderSet = False Then
                .Cells(NextRow, "G").Value = "Geen"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 0 Then
                .Cells(NextRow, "G").Value = "0 minuten"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 5 Then
                .Cells(NextRow, "G").Value = "5 minuten"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 10 Then
                .Cells(NextRow, "G").Value = "10 minuten"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 15 Then
                .Cells(NextRow, "G").Value = "15 minuten"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 30 Then
                .Cells(NextRow, "G").Value = "30 minuten"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 60 Then
                .Cells(NextRow, "G").Value = "1 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 120 Then
                .Cells(NextRow, "G").Value = "2 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 180 Then
                .Cells(NextRow, "G").Value = "3 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 240 Then
                .Cells(NextRow, "G").Value = "4 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 300 Then
                .Cells(NextRow, "G").Value = "5 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 360 Then
                .Cells(NextRow, "G").Value = "6 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 420 Then
                .Cells(NextRow, "G").Value = "7 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 480 Then
                .Cells(NextRow, "G").Value = "8 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 540 Then
                .Cells(NextRow, "G").Value = "9 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 600 Then
                .Cells(NextRow, "G").Value = "10 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 660 Then
                .Cells(NextRow, "G").Value = "11 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 720 Then
                .Cells(NextRow, "G").Value = "0" & Chr(130) & "5 dagen"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 1080 Then
                .Cells(NextRow, "G").Value = "18 uur"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 1440 Then
                .Cells(NextRow, "G").Value = "1 dag"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 2880 Then
                .Cells(NextRow, "G").Value = "2 dagen"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 4320 Then
                .Cells(NextRow, "G").Value = "3 dagen"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 5760 Then
                .Cells(NextRow, "G").Value = "4 dagen"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 10080 Then
                .Cells(NextRow, "G").Value = "1 week"
                ElseIf olApt.ReminderSet = True And olApt.ReminderMinutesBeforeStart = 20160 Then
                .Cells(NextRow, "G").Value = "2 weken"
                End If
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan