Link to Outlook, small query

[wh00t]

Greetings all.

There are several customers which use a service booking database and it works very well, but it would be great if it could link to outlook for certain things.

I have added a few functions within access already that different things, listed below, may help people. But what I would like now is to be able to edit an existing outlook record from within access, I'm having no luck so far.

here's what works so far

Create an appointment (Late binding is used as the customers have different outlook versions)

Dim appOutlook As Object
Dim objAppt As Object
Dim objCal As Object
Dim objNS As Object
Dim objProp As Object

Set appOutlook = CreateObject("Outlook.Application")
Set objNS = appOutlook.GetNamespace("MAPI")
Set objCal = objNS.GetDefaultFolder(9).Folders("Custom Calendar") '9 = olFolderCalendar
Set objAppt = objCal.Items.Add(1) '1 = olAppointmentItem

objAppt.MessageClass = "IPM.Appointment.CustomForm" 'define which outlook form to use
Set objProp = objAppt.UserProperties.Add("Customer", 1) 'specify custom outlook field, 1 = oltext

If IsNull(Me.t1) Then 'already added to outlook
    With objAppt
        .Subject = "Service Booking - " & Me.ID & " - " & Me.Reg
        .start = Me.start
        .End = Me.End
        .Body = "Service Booking for - " & Me.Reg & " " & Me.Vehicle
        .ReminderSet = False
        .UserProperties("Customer") = Me.customer
        .Save
        Me.t1 = objAppt.EntryID
    End With
End If

Set objAppt = Nothing
Set appOutlook = Nothing
Set objCal = Nothing

Import any entry made via outlook

Dim appOutlook As Object
Dim objCal As Object
Dim objNS As Object
Dim i As Integer
Dim Rst As New ADODB.Recordset
Dim Rst2 As New ADODB.Recordset

Set appOutlook = CreateObject("Outlook.Application")
Set objNS = appOutlook.GetNamespace("MAPI")
Set objCal = objNS.GetDefaultFolder(9).Folders("Custom Calendar") '9 = olFolderCalendar
Rst2.Open "SELECT * FROM Table2", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

'compare with existing access records and add to access if new in outlook
For i = objCal.Items.Count To 1 Step -1
    Rst.Open "SELECT * FROM Table1 WHERE t1 = " & objCal.Items.Item(i).EntryID, CurrentProject.Connection, adOpenKeyset, adLockOptimist
    If Rst.EOF Then
        On Error Resume Next ' avoid error if custom field is blank
        Rst2.AddNew
        Rst2!EntryID = objCal.Items.Item(i).EntryID
        Rst2!start = objCal.Items.Item(i).start
        Rst2!End = objCal.Items.Item(i).End
        Rst2!customer = objCal.Items.Item(i).UserProperties("Customer") 
        Rst2!bookedwhen = objCal.Items.Item(i).CreationTime
        Rst2.Update
    End If
    Rst.Close
Next

Set appOutlook = Nothing
Set objCal = Nothing
Rst2.Close
Me.OutList.Requery

Compare records to see if the outlook entry has been changed

Dim appOutlook As Object
Dim objCal As Object
Dim objNS As Object
Dim i As Integer

Set appOutlook = CreateObject("Outlook.Application")
Set objNS = appOutlook.GetNamespace("MAPI")
Set objCal = objNS.GetDefaultFolder(9).Folders("Custom Calendar") '9 = olFolderCalendar

For i = objCal.Items.Count To 1 Step -1
    If objCal.Items.Item(i).EntryID = Me.EntryID Then
        'objCal.Items.Item(i).Display 'opens outlook appt record
        Me.SubCheck = objCal.Items.Item(i).Subject
        Me.StrCheck = objCal.Items.Item(i).start
        Me.EndCheck = objCal.Items.Item(i).End
        Me.ModCheck = objCal.Items.Item(i).LastModificationTime
    End If
Next

Set appOutlook = Nothing
Set objCal = Nothing

 

[wh00t]

sorted, had a thought

now create new record and delete old

Dim appOutlook As Object
Dim objCal As Object
Dim objNS As Object
Dim objAppt As Object
Dim objColl As Object
Dim i As Integer
Dim tmp As String

Set appOutlook = CreateObject("Outlook.Application")
Set objNS = appOutlook.GetNamespace("MAPI")
Set objCal = objNS.GetDefaultFolder(9).Folders("Custom Calendar") '9 = olFolderCalendar
Set objAppt = objCal.Items.Add(1) '1 = olAppointmentItem <<<<edit???

For i = objCal.Items.Count To 1 Step -1
    If objCal.Items.Item(i).EntryID = Me.t1 Then
        tmp = objCal.Items.Item(i).EntryID
        With objAppt
            .Subject = "Booking - " & Me.ID & " - " & Me.customer
            .start = Me.start
            .End = Me.End
            .Body = "Service for - " & Me.Reg & " " & Me.Vehicle
            .ReminderSet = False
            .UserProperties("Customer") = Me.customer
            .Save
            Me.t1 = objAppt.EntryID
        End With
        Set objColl = objNS.GetItemFromID(tmp)
        objColl.Delete
        GoTo StepOut
    End If
Next
GoTo StepOut

StepOut:
Set appOutlook = Nothing
Set objCal = Nothing
Set objAppt = Nothing
Set objColl = Nothing