dragnor Juniormester
06. februar 2017 - 19:22 Der er 11 kommentarer og
1 løsning

Brug af MS Access til Extract af Outlook Calendar Appointments

Hej Eksperter,

Jeg har et par udfordringer som jeg ikke kan løse.

Jeg har fået en opgave, hvor jeg skal udtrække alle aftaler fra en bunke Delte kalendere i Outlook 2013. Jeg kan sagtens se kalenderne og alle aftaler men har følgende 2 store udfordringer:

Første udfordring er at jeg ikke kan få "Restrict" til at virke, så istedet for et udsnit af aftaler får jeg hver gang alle aftaler.

Det er denne kode jeg basalt set bruger:

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 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(Date, "yyyy/mm/dd") & "' AND [Start] <= '" & Format(Date + 14, "yyyy/mm/dd") & "'"
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


Næste problem jeg har er med Gentagene aftaler "Recurrences"
Det "eneste" jeg ønsker er at tage all Gentagene aftaler ud på de præcise dage og tidspunkter som også kan ses når man åbner kalenderen. Men jeg får konstant "Master" aftalens start og slut dato og tidspunkter.
Jeg har nu søgt højt og lavt i 2 uger på nettet og har nu kastet håndklædet i ringen og det er derfor jeg henvender mig til jer herinde.

På forhånd 1000 1000 1000 tak for alt den hjælp jeg kan få.
terry Ekspert
06. februar 2017 - 20:22 #1
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.
dragnor Juniormester
06. februar 2017 - 20:35 #2
Hi Terry,

It helped with the Filter :-)

But now i'm still facing the issue regarding Recurrence :-(
terry Ekspert
06. februar 2017 - 20:39 #3
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
terry Ekspert
06. februar 2017 - 20:41 #4
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
dragnor Juniormester
06. februar 2017 - 21:02 #5
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
terry Ekspert
07. februar 2017 - 09:16 #6
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
dragnor Juniormester
07. februar 2017 - 12:29 #7
You got mail
terry Ekspert
07. februar 2017 - 12:54 #8
Could you send it again but first rename .bas file as its getting blocked by Outlook
dragnor Juniormester
07. februar 2017 - 13:03 #9
done
terry Ekspert
07. februar 2017 - 13:22 #10
received, back asap
terry Ekspert
07. februar 2017 - 15:23 #11
Mail sent
dragnor Juniormester
07. februar 2017 - 19:04 #12
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
Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links

Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester





Premium
Test: Kæmpestort gaming-headset er perfekt til dine lange Teams-møder - men har også nogle besværligheder
Længe før vi andre blev slået hjem til hjemmekontorets endeløse webmøder har gamerne gennemskuet behovet for komfortabelt grej. Så vi tog danske EPOS top gamingheadset med på arbejde. Læs testen her.
Computerworld
Biden sender skjult besked til kode-folket: "Hvis du læser dette, har vi brug for din hjælp”
En stående invitation er blevet opdaget i kildekoden på Det Hvide Hus' hjemmeside. Men den er kun til de eksperter, der selv kan finde den.
CIO
Podcast: Hos Viking Life-Saving Equipment er it gået fra at være backend til at være noget, som kunderne spørger aktivt efter
Podcast, The Digital Edge: Viking leverer en stadig større del af deres produkt som en tjeneste. Som en del af tjenesten tager Viking ansvar for sikkerheden ved at levere, dokumentere og vedligeholde det nødvendige sikkerhedsudstyr. Hør hvordan Henrik Balslev senior digital director hos Viking har løftet den opgave.
White paper
Fri medarbejdermobilitet - med digital bodyguard
Om at gå fra adgangsstyring på personniveau til adgangsstyring på desktopniveau. I takt med at flere og flere medarbejdere arbejder remote og logger på jeres systemer og netværk uden for virksomhedens sikkerhedsværn, risikerer de at efterlade døren til forretningen på klem. Dermed bliver endpoints som pc’ere, Mac’s og servere et oplagt mål for hackere, som vil ind i virksomhedens infrastruktur. I blandt sker det også, at medarbejdere udnytter deres privilegerede adgangsrettigheder til skadelige formål. Det er derfor mere aktuelt end nogensinde at rette opmærksomheden mod jeres endpoints og de rettigheder, der ligger her.