Extracting Calender Items Out of Outlook From Access 
Author Message
 Extracting Calender Items Out of Outlook From Access

Hi Tim,

This may get you started. This is a piece of code from a
UserForm created in Outlook using VBA. The form contains a
calendar control and a commandbutton

----> is comments I added to this code.

By the way, the code isn't optimized or cleaned up.

Regards,

Bart

Private Sub CommandButton2_Click()

Dim currentappointment As AppointmentItem
Dim wkstart As Date
Dim overview As String

wkstart = Calendar.Value ---> get the start day from the
calendar control
wkend = wkstart + 7 ---> set end day one week later

Set myOlApp = CreateObject("Outlook.Application")
Set mynamespace = myOlApp.GetNamespace("MAPI")
tdystart = Format(wkstart, "Short Date") & " 12:00 AM" ---

Quote:
> format start and end in Outlook string format

tdyend = Format(wkend, "Short Date") & " 11:59 PM"
Set myAppointments = mynamespace.GetDefaultFolder _
    (olFolderCalendar).Items ---> access your calendar
items
Set currentappointment = myAppointments.Find("[Start]
Quote:
>= '" & _

    tdystart & "' and [Start] <= '" & tdyend & "'")
While TypeName(currentappointment) <> "Nothing"
    MsgBox currentappointment.Start  ---> display the
start for each appointment within the time period [start -
end]
    Set currentappointment = myAppointments.FindNext
Wend

End Sub

Quote:
>-----Original Message-----
>I am trying to work out how to get my scheduling tool
>(Access 2000) to get the data from my Outlook Calender.  
I
>am using Office 2000 and once I get the data I can easily
>deal with it, however I have not found a way to retrieve
>this infomation.

>I would like to be able to ultimately allow a user to
>select from a list and choose to get a Calender Item,
>Task, Contact etc., and then select from within a defined
>date range.  

>If anyone can give me a place to start with the Calender
>Item I can probably figure out the rest from there.

>Thanks

>Tim
>.



Fri, 13 May 2005 18:40:28 GMT  
 Extracting Calender Items Out of Outlook From Access

ALERT! The attached subs/functions contained in the attached file are
provided as reference only.

That said...

The attached file contains the subs/functions that I wrote over a year
ago to extract calendar information from Exchange and save it in an
Access database. Since its been a year, it would take awhile to sort out
  problems with it. Also, I had to scrape the project prior to finishing
it, however as I recall I did get rather far along with it. (But not to
the point of adding comments.)

Things to be aware of:
1. The code will automatically create an email message that will recap
the results.
2. I always had problems with reoccurring appointments. Specifically,
retrieving a specific occurrance. (Really ugly problems.)
3. The code is designed to capture calendar items within the next couple
of days.
4. As I recall, anything marked as PRIVATE would not be retrived. (I
think that there is something else that was excluded, but can't remember
what.)
5. Items falling on a Saturday/Sunday will not be retrived. (I think.)
6. The code does not like situations where conflicting changes to a
calendar item have been made. (i.e. Person A invites you to a meeting.
You make a change to the item in your PDA. Person A changes the meeting.
You sync your PDA to Outlook.)
7. PUBLISH_CALENDAR is the sub to call to execute the code.
8. The code was developed in a Corporate Workgroup setting with all of
our mailboxes running on Exchange. It is designed to loop through all
calendar folders to which your user ID has been given read access.

David

Quote:

> Hi Tim,

> This may get you started. This is a piece of code from a
> UserForm created in Outlook using VBA. The form contains a
> calendar control and a commandbutton

> ----> is comments I added to this code.

> By the way, the code isn't optimized or cleaned up.

> Regards,

> Bart

> Private Sub CommandButton2_Click()

> Dim currentappointment As AppointmentItem
> Dim wkstart As Date
> Dim overview As String

> wkstart = Calendar.Value ---> get the start day from the
> calendar control
> wkend = wkstart + 7 ---> set end day one week later

> Set myOlApp = CreateObject("Outlook.Application")
> Set mynamespace = myOlApp.GetNamespace("MAPI")
> tdystart = Format(wkstart, "Short Date") & " 12:00 AM" ---

>>format start and end in Outlook string format

> tdyend = Format(wkend, "Short Date") & " 11:59 PM"
> Set myAppointments = mynamespace.GetDefaultFolder _
>     (olFolderCalendar).Items ---> access your calendar
> items
> Set currentappointment = myAppointments.Find("[Start]

>>= '" & _

>     tdystart & "' and [Start] <= '" & tdyend & "'")
> While TypeName(currentappointment) <> "Nothing"
>     MsgBox currentappointment.Start  ---> display the
> start for each appointment within the time period [start -
> end]
>     Set currentappointment = myAppointments.FindNext
> Wend

> End Sub

>>-----Original Message-----
>>I am trying to work out how to get my scheduling tool
>>(Access 2000) to get the data from my Outlook Calender.  

> I

>>am using Office 2000 and once I get the data I can easily
>>deal with it, however I have not found a way to retrieve
>>this infomation.

>>I would like to be able to ultimately allow a user to
>>select from a list and choose to get a Calender Item,
>>Task, Contact etc., and then select from within a defined
>>date range.  

>>If anyone can give me a place to start with the Calender
>>Item I can probably figure out the rest from there.

>>Thanks

>>Tim
>>.

[ Web_Calendar.bas 12K ]
Attribute VB_Name = "Web_Calendar"
'Option Explicit
    Dim objOutlook As Application
    Dim bodyText As String
    Dim itmOutgoingMessage As Outlook.MailItem
    Dim nms As Outlook.nameSpace
    Dim mailbox As Outlook.MAPIFolder
    Dim calendar As Outlook.MAPIFolder
    Dim itmOutgoingMessageOpen As Integer
    Dim mailboxName As String
    Dim batchID As String
    Dim calendarItems As Items
    Dim calendarItemsAll As Items
    Dim i As Long
    Dim j As Long
    Dim rstData As Recordset
    Dim rstHeader As Recordset
    Dim frequency As RecurrencePattern
    Dim currentItm As appointmentItem

Public Sub Publish_Calendar()
'Note: There will be a performance hit retrieving a user's appointments, if the user
'is logged in to their account.

    Dim dao As Object
    Dim wks As Workspace
    Dim dbs As Database
    Dim publishCalendar As Integer
    Dim MsgText As String
    Dim response As Double
    Dim strRestrict As String

    On Error GoTo Error_Publish_Calendar_General

    Set dao = CreateObject("DAO.DBEngine.36")
    Set wks = dao.Workspaces(0)
    Set dbs = wks.OpenDatabase("P:\Web_Calendar.mdb")
    Set rstData = dbs.OpenRecordset("tblCalendar_Data")
    Set rstHeader = dbs.OpenRecordset("tblCalendar_Header")
    Set objOutlook = CreateObject("Outlook.application")
    Set nms = objOutlook.GetNamespace("MAPI")
    Set itmOutgoingMessage = objOutlook.CreateItem(olMailItem)

    On Error GoTo Error_Publish_Calendar
    itmOutgoingMessageOpen = 0
    batchID = CDbl(Now())
    Debug.Print batchID
    itmOutgoingMessage.To = "David Holley"
    itmOutgoingMessage.Subject = "Publish Calendar Error Log - Batch# " & batchID
    itmOutgoingMessage.Body = Now() & Chr$(9)
    itmOutgoingMessage.Body = itmOutgoingMessage.Body & "Batch #" & batchID & " started" & Chr$(13)
    itmOutgoingMessageOpen = 1
    'Load frmStatus
    'frmStatus.Show vbModeless

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Begin looping through all open mailboxes & calendar to retrieve AppointmentItems
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'frmStatus.Controls(1).Caption = "Processing..."
    'frmStatus.Repaint
    On Error GoTo Error_I_Loop              'Skip to next mailbox if error
    For i = 1 To nms.Folders.count
        publishCalendar = 1
        Set mailbox = nms.Folders(i)
        If mailbox.Name Like "Mailbox" & "*" Then
            mailboxName = Mid(mailbox.Name, 11, Len(mailbox.Name) - 10)
            Debug.Print "-------------------------------------------------"
            Debug.Print mailboxName
            Debug.Print "-------------------------------------------------"
            'frmStatus("mailboxName").Caption = mailboxName
            Set calendar = mailbox.Folders("Calendar")
            Set calendarItemsAll = calendar.Items
            calendarItemsAll.IncludeRecurrences = True
            calendarItemsAll.Sort ("[Start]")
            strRestrict = "[Start] > """ & DateAdd("d", -1, Date) & """"
            Set calendarItems = calendarItemsAll.Restrict(strRestrict)
            calendarItems.IncludeRecurrences = True
            calendarItems.Sort ("[Start]")
            Call Publish_Appointments
            Call Update_Header(rstHeader, mailbox, batchID)
        End If

Next_I:
        'frmStatus.Controls(1).Caption = "Mailbox " & i & " of " & nms.Folders.count & " processed"
    Next i

    rstData.Close
    rstHeader.Close

    itmOutgoingMessage.Body = itmOutgoingMessage.Body & Now & Chr$(9)
    itmOutgoingMessage.Body = itmOutgoingMessage.Body & "Batch #" & batchID & " completed" & Chr$(13)
    itmOutgoingMessage.Send

Exit_Publish_Calendar:
    'frmStatus.Hide
    'Unload frmStatus
    Exit Sub

Error_Publish_Calendar_General:
'Error processing for general errors that might occur, usually expected at the top of the
'code where the object variables are being set.
    MsgText = ""
    MsgText = MsgText & "An unexpected error has occurred that prevents further execution of the code." & Chr$(13)
    MsgText = MsgText & "Error " & CStr(Err) & " : " & Error$(Err) & Chr$(13)
    response = MsgBox(MsgText, 16, "Publish_Calendar")
    GoTo Exit_Publish_Calendar

Error_Publish_Calendar:
    If i > 0 Then
        Call Log_Error
        Resume Next
    End If
    If i = 0 Then
        If itmOutgoingMessageOpen = 1 Then
            bodyText = ""
            bodyText = bodyText & "An unexpected error has occurred that prevents further execution of the code." & Chr$(13)
            bodyText = bodyText & "Error " & CStr(Err) & " : " & Error$(Err) & Chr$(13)
            itmOutgoingMessage.Subject = "Publish Calendar Failure"
            itmOutgoingMessage.Body = itmOutgoingMessage.Body & Now & Chr$(9)
            itmOutgoingMessage.Body = itmOutgoingMessage.Body & Chr$(13)
            itmOutgoingMessage.Body = itmOutgoingMessage.Body & bodyText & Chr$(13)
            itmOutgoingMessage.Send
        End If
        GoTo Error_Publish_Calendar_General
    End If

Error_I_Loop:
    Call Log_Error
    Resume Next_I

End Sub

Private Static Function Include_Appointment()
'Function imposes rules to determine if the appointment falls on a weekday and during business hours

Dim daysOut As Integer

On Error GoTo Error_Include_Appointment

Include_Appointment = 1

'Exclude non-reoccurring appointments in the past
If currentItm.End < Date Then
    Include_Appointment = 0
    Exit Function
End If

'''''''''''''''''''''CHANGE CODE TO REFERENCE THE SPECIFIC OCCURRENCE''''''''''''''''''''''''''''''
'Exclude private appointments that are All Day Events
If currentItm.Sensitivity = 2 And currentItm.AllDayEvent Then
    Include_Appointment = 0
    Exit Function
End If

'Exclude Dates x days out and further
daysOut = 8
If DatePart("w", Date) = 6 Then daysOut = daysOut + 2       'Include the following Monday if today = Friday

If currentItm.Start > Date + daysOut Then
    Include_Appointment = 0
    Exit Function
End If

'Exclude Sundays
If DatePart("w", currentItm.Start) = 1 Then
    Include_Appointment = 0
    Exit Function
End If

'Exclude Saturdays
If DatePart("w", currentItm.Start) = 7 Then
    Include_Appointment = 0
    Exit Function
End If

'Exclude appointments before 7:55 AM (.33 * 24)
If TimeValue(currentItm.Start) < 0.33 Then
    If currentItm.Start = currentItm.End Then
        Include_Appointment = 0
        Exit Function
    End If
End If

'Exclude appointments after 17:31 PM (.73 * 24)
If TimeValue(currentItm.Start) > 0.73 Then
    Include_Appointment = 0
    Exit Function
End If

Exit Function

Error_Include_Appointment:
Call Log_Error

End Function

Public Sub Log_Error()

    itmOutgoingMessage.Body = itmOutgoingMessage.Body & Now & Chr$(9)
    itmOutgoingMessage.Body = itmOutgoingMessage.Body & "Error:  " & Err & Chr$(9)
    itmOutgoingMessage.Body = itmOutgoingMessage.Body & Error$(Err) & Chr$(9)
    itmOutgoingMessage.Body = itmOutgoingMessage.Body & nms.Folders(i).Name & Chr$(13)
    Exit Sub

End Sub
Private Sub Update_Header(headerTable As Recordset, currentMailbox As Outlook.MAPIFolder, ByVal batch As String)

    Dim mailboxExists As Integer

    mailboxExists = 0
    If Not headerTable.EOF Then
        While (Not headerTable.EOF And mailboxExists = 0)
            If Mid(currentMailbox.Name, 11, (Len(headerTable!Name))) = headerTable!Name Then
                headerTable.Edit
                headerTable!batchID = Mid(currentMailbox.Name, 11, (Len(currentMailbox.Name)) - 10) & batch
                headerTable!Last_Updated = Now()
                headerTable.Update
                mailboxExists = 1
            End If
            headerTable.MoveNext
        Wend
    End If

    'If the header does not exist, create a new one
    If mailboxExists <> 1 Then
        headerTable.AddNew
        headerTable!Name = Mid(currentMailbox.Name, 11, (Len(currentMailbox.Name)) - 10)
        headerTable!batchID = Mid(currentMailbox.Name, 11, (Len(currentMailbox.Name)) - 10) & batch
        headerTable!Last_Updated = Now()
        headerTable.Update
    End If

    headerTable.MoveFirst 'Always move back to the first record to insure that all records are read

End Sub

Private Sub Publish_Appointments()

On Error GoTo Error_Read_Appointments

    Dim varAppointmentStart As Date
    Dim varAppointmentEnd As Date
    Dim itm As Object
    Dim k As Integer
    Dim eventDuration As Integer
    Dim pattern As RecurrencePattern

    For Each itm In calendarItems
        'Open A If...Then
        If TypeName(itm) = "AppointmentItem" Then
        '    If Not itm.IsRecurring Then
        '        Set currentItm = itm
        '    Else
        '        Set pattern = itm.GetRecurrencePattern
        '        Stop
        '        Set currentItm = pattern.GetOccurrence(itm.Start)
        '        Stop
        '    End If
            'Open B If...Then
            If Include_Appointment() Then
                If DateDiff("d", DateAdd("w", 1, Date), currentItm.Start) > 0 Then Exit For
                If currentItm.AllDayEvent And currentItm.Start < Date And currentItm.End > Date Then
                    varAppointmentStart = Date
                End If
                If currentItm.AllDayEvent Then
                    varAppointmentEnd = varAppointmentStart
                End If
                varAppointmentStart = currentItm.Start
                varAppointmentEnd = currentItm.End
                rstData.AddNew
                rstData!Start = varAppointmentStart
                rstData!End = varAppointmentEnd
                If currentItm.Sensitivity = 2 Then
                    rstData!Subject = "BUSY"
                    Else
                    rstData!Subject = currentItm.Subject
                    rstData!Location = currentItm.Location
                End If
                rstData!batchID = mailboxName & CStr(batchID)
...

read more »



Fri, 20 May 2005 18:11:04 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. HowTo create Outlook calender items from VBScript

2. Extract Text from Mail Body and write in Calender

3. Extract outlook messages w/ attachments to load to Access DB

4. Moving items from one Calender to another

5. How to create appointment calender from calender in VB

6. How to create the calender in MDI form without using vbBuilt in Calender Function

7. Linking from webpage to Outlook calender

8. Outlook public calender

9. Automatiing Outlook Calender

10. Updating Outlook calender from asp or java application

11. Export Outlook Calender to website

12. Automatiing Outlook Calender

 

 
Powered by phpBB® Forum Software