Brug af MS Access til Extract af Outlook Calendar Appointments

If you haven't looked at this link already it might help.
https://msdn.microsoft.com/en-us/library/office/ff869597.aspx

Take a look at how date fields need to be formatted.

Hi Terry,

It helped with the Filter :-)

But now i'm still facing the issue regarding Recurrence :-(

Great to hear it helped ;-)

I'll need to read up a little on Recurrences, haven't really used them myself. Back asap, maybe first tomorrow

Just thought of something!

You are setting a date range, can that maybe be filtering out recurrences?

Try with a date range which you know includes a recurrence

No, i'm looping through a date range, that is also why I need the filtering to work :-)

i'm trying something like this, where C_DATE is a specific date, but "rp.GetOccurrence" does not seem to work for me:

Dim rp As Outlook.RecurrencePattern
        Set rp = Nothing
        Set rp = appt.GetRecurrencePattern()
       
        Set MyAppointment = Nothing

        'On Error Resume Next
        Set MyAppointment = rp.GetOccurrence(Format$(C_DATE & Right(appt.Start, 9), "dd/mm/yyyy hh:mm AMPM"))
       
       
        On Error GoTo err
        If TypeName(MyAppointment) = "Nothing" Then
            GoTo nextitem
        End If

The code your showing now isn't the same as the first, any chance of you sending the full code you are using as I'll need to debug through code to try and find problem.

ekspertenATsanthell.dk
AT = @

I'll be gone for an hour or so, will look again later

You got mail

Could you send it again but first rename .bas file as its getting blocked by Outlook

done

received, back asap

Mail sent

Dette lader til at virke:

Option Compare Database


Function loop_period()
Dim loop_Date As Date
loop_Date = Date

Do Until loop_Date = Date + 14
    'Debug.Print "New Period: " & loop_Date
    get_calendar loop_Date
loop_Date = loop_Date + 1
Loop
Debug.Print "Done"
End Function


Function get_calendar(C_DATE As Date)
On Error GoTo err
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.namespace
Dim appt As Outlook.AppointmentItem
Dim objOwner As Outlook.recipient
Dim str_sql As String
Dim STR_OWNER As String
Dim item_Start_date As String
Dim item_Start_time As String
Dim app_Start As Date
Dim app_End As Date

Dim FolderCal As Object
Dim Occur As Object
Dim i As Long
Dim strRestriction As String
Dim myStart As Date
Dim myEnd As Date
Const olFolderCalendar = 9

myStart = C_DATE
myEnd = C_DATE


strRestriction = "[Start]>= '" & Format$(C_DATE & " 00:01", "dd/mm/yyyy hh:mm AM") & "' AND [Start] <= '" & Format$(C_DATE & " 11:59", "dd/mm/yyyy hh:mm PM") & "'"
'Debug.Print "Restriction: " & strRestriction
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")

STR_OWNER = "Thomas"

Set objOwner = oNs.CreateRecipient(STR_OWNER)
objOwner.Resolve

If objOwner.Resolved Then
    Set FolderCal = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If

Set ItemsApt = FolderCal.Items

ItemsApt.IncludeRecurrences = True
ItemsApt.Sort "[Start]"
Set oItemsInDateRange = ItemsApt.Restrict(strRestriction)
oItemsInDateRange.IncludeRecurrences = True
oItemsInDateRange.Sort "[Start]"



For Each appt In oItemsInDateRange

    If appt.RecurrenceState <> 0 Then
        app_Start = DateAdd("n", 0, CStr(C_DATE) & Right(appt.Start, 9))
        app_End = DateAdd("n", 0, CStr(C_DATE) & Right(appt.End, 9))
    Else
        app_Start = appt.Start
        app_End = appt.End
    End If
    'Debug.Print "Subject: " & appt.Subject
    'Debug.Print "New date: " & app_Start
    'Debug.Print "Appointment date: " & appt.Start
    'Debug.Print "Is Recurrence: " & appt.RecurrenceState
    'If Not IsNull(DLookup("ID", "T_CAL_B_OUTLOOK_CALENDAR", "ID='" & appt.EntryID & "'")) Then
    If DCount("*", "T_CAL_B_OUTLOOK_CALENDAR", "ID='" & appt.EntryID & "' AND LM='" & CStr(appt.LastModificationTime) & "' AND Start=#" & sql_date(CStr(app_Start)) & "#") > 0 Then
        GoTo nextitem
    End If
   
   
   
    str_sql = "insert into T_CAL_B_OUTLOOK_CALENDAR(Calendar_Owner, ID, Start, End, Subject, Duration, AllDayEvent, Importance, IsRecurring, MeetingStatus, Organizer, ResponseStatus, UnRead, LM) "
    str_sql = str_sql & "VALUES("
    str_sql = str_sql & Chr(34) & STR_OWNER & Chr(34) & ","
    str_sql = str_sql & Chr(34) & appt.EntryID & Chr(34) & ","
    str_sql = str_sql & "#" & sql_date(CStr(app_Start)) & "#,"
    str_sql = str_sql & "#" & sql_date(CStr(app_End)) & "#,"
    str_sql = str_sql & Chr(34) & appt.Subject & Chr(34) & ","
    str_sql = str_sql & "'" & appt.Duration & "',"
    str_sql = str_sql & appt.AllDayEvent & ","

   
    If appt.Importance = olImportanceLow Then
        str_sql = str_sql & "'Low',"
    ElseIf appt.Importance = olImportanceNormal Then
        str_sql = str_sql & "'Normal',"
    ElseIf appt.Importance = olImportanceHigh Then
        str_sql = str_sql & "'High',"
    Else
        str_sql = str_sql & "'Normal',"
    End If
   
    str_sql = str_sql & appt.IsRecurring & ","
   
    If appt.MeetingStatus = olMeeting Then
        str_sql = str_sql & "'Meeting',"
    ElseIf appt.MeetingStatus = olMeetingCanceled Then
        str_sql = str_sql & "'Canceled',"
    ElseIf appt.MeetingStatus = olMeetingReceived Then
        str_sql = str_sql & "'Received',"
    ElseIf appt.MeetingStatus = olMeetingReceivedAndCanceled Then
        str_sql = str_sql & "'Received And Canceled',"
    ElseIf appt.MeetingStatus = olNonMeeting Then
        str_sql = str_sql & "'None Meeting',"
    Else
        str_sql = str_sql & "'Meeting',"
    End If
   
    str_sql = str_sql & Chr(34) & appt.Organizer & Chr(34) & ","
   
    If appt.ResponseStatus = olResponseAccepted Then
        str_sql = str_sql & "'Accepted',"
    ElseIf appt.ResponseStatus = olResponseDeclined Then
        str_sql = str_sql & "'Declined',"
    ElseIf appt.ResponseStatus = olResponseNone Then
        str_sql = str_sql & "'None Response',"
    ElseIf appt.ResponseStatus = olResponseNotResponded Then
        str_sql = str_sql & "'Not Responded',"
    ElseIf appt.ResponseStatus = olResponseOrganized Then
        str_sql = str_sql & "'Organized',"
    ElseIf appt.ResponseStatus = olResponseTentative Then
        str_sql = str_sql & "'Tentative',"
    Else
        str_sql = str_sql & "'Accepted',"
    End If
   
    str_sql = str_sql & appt.UnRead & ","
    str_sql = str_sql & "'" & appt.LastModificationTime & "')"
   
    CurrentDb.Execute str_sql

       
nextitem:
Next

Exit Function
err:

'If err.Number < 0 Then
'    Set objPattern = Nothing
'    GoTo nextitem
'End If

Debug.Print err.Number & " - " & err.Description
Resume
End Function


Function sql_date(strdate As String) As String
Dim dd As String
Dim mm As String
Dim yy As String
Dim str_time As String

If InStr(1, strdate, ":") > 0 Then
    str_time = Right(strdate, 8)
    strdate = Left(strdate, 10)
   
    dd = Left(strdate, 2)
    mm = Right(Left(strdate, 5), 2)
    yy = Right(strdate, 4)
   
    sql_date = mm & "/" & dd & "/" & yy & " " & str_time
Else
    dd = Left(strdate, 2)
    mm = Right(Left(strdate, 5), 2)
    yy = Right(strdate, 4)
   
    sql_date = mm & "/" & dd & "/" & yy
End If


End Function


Function sql_date2(strdate As String) As String
Dim dd As String
Dim mm As String
Dim yy As String
Dim str_time As String


dd = Left(strdate, 2)
mm = Right(Left(strdate, 5), 2)
yy = Right(strdate, 4)

sql_date2 = yy & "/" & mm & "/" & dd
End Function

Function sql_date3(strdate As String) As String
Dim dd As String
Dim mm As String
Dim yy As String
Dim str_time As String

strdate = Left(strdate, 10)

dd = Left(strdate, 2)
mm = Right(Left(strdate, 5), 2)
yy = Right(strdate, 4)

sql_date3 = mm & "/" & dd & "/" & yy
End Function

Function sql_date_O(strdate As String) As String
Dim dd As String
Dim mm As String
Dim yy As String
Dim str_time As String
If InStr(1, strdate, ":") > 0 Then
    str_time = Right(strdate, 8)
    strdate = Left(strdate, 10)
   
    dd = Left(strdate, 2)
    mm = Right(Left(strdate, 5), 2)
    yy = Right(strdate, 4)
   
    sql_date_O = dd & "/" & mm & "/" & yy & " " & str_time
Else
    dd = Left(strdate, 2)
    mm = Right(Left(strdate, 5), 2)
    yy = Right(strdate, 4)
   
    sql_date_O = dd & "/" & mm & "/" & yy
End If

End Function