---

Hej Alle

Er der nogle af Jer der har rodet med appointments og outlook.

Jeg kalder mit modul med et array fyldt med appointmentdata. Et element i
arrayet er EntryID.
Jeg skal derefter søge outlook-appointment igennem og se om denne EntryID
allerede eksisterer. Hvis det gør skal denne appointments data rettes.
Findes den ikke skal den oprettes i kalenderen.

Alt dette har jeg fået til at fungere uden problemer.
Mit problem er at søgningen efter EntryID's er frygtelig langsomt. Den søger
alle objekter i kalenderen igennem hver gang. Det må kunne gøres bedre.

Her er min kode

FORM:
Private Sub Command1_Click()
Dim syncdata() As Variant
Dim ReturnArray As Variant
Dim I As Integer

Call PopulateTestData(syncdata)

ReturnArray = Outlook_Sync(syncdata)

For I = LBound(ReturnArray) To UBound(ReturnArray)
Me.Text1.Text = Me.Text1.Text + ReturnArray(I, 1) + vbNewLine
Next I

'TEST: Set brake here and look in the calender then continue
syncdata(0, 1) = ReturnArray(0, 1)
syncdata(0, 2) = "Overskriften er nu ændret"

syncdata(1, 1) = ReturnArray(1, 1)
syncdata(1, 2) = "Overskriften er ikke det samme som før"

ReturnArray = Outlook_Sync(syncdata)
End Sub

Private Sub PopulateTestData(syncdata As Variant)

ReDim Preserve syncdata(2, 14)

syncdata(0, 0) = 10000
syncdata(0, 1) = ""
syncdata(0, 2) = "Overskrift0"
syncdata(0, 3) = Date
syncdata(0, 4) = Time
syncdata(0, 5) = DateAdd("h", 2, Time)
syncdata(0, 6) = "Beskrivelse0"
syncdata(0, 7) = "Footer0"
syncdata(0, 8) = "Karlslunde0"
syncdata(0, 9) = 30
syncdata(0, 10) = "n/a"
syncdata(0, 11) = "n/a"
syncdata(0, 12) = "n/a"
syncdata(0, 13) = "n/a"
syncdata(0, 14) = "n/a"

syncdata(1, 0) = 11000
syncdata(1, 1) = ""
syncdata(1, 2) = "Overskrift1"
syncdata(1, 3) = DateAdd("d", 1, Date)
syncdata(1, 4) = Time
syncdata(1, 5) = DateAdd("h", 1, Time)
syncdata(1, 6) = "Beskrivelse1"
syncdata(1, 7) = "Footer1"
syncdata(1, 8) = "Karlslunde1"
syncdata(1, 9) = 30
syncdata(1, 10) = "n/a"
syncdata(1, 11) = "n/a"
syncdata(1, 12) = "n/a"
syncdata(1, 13) = "n/a"
syncdata(1, 14) = "n/a"

syncdata(2, 0) = 11000
syncdata(2, 1) = ""
syncdata(2, 2) = "Overskrift2"
syncdata(2, 3) = DateAdd("d", 2, Date)
syncdata(2, 4) = Time
syncdata(2, 5) = DateAdd("h", 1, Time)
syncdata(2, 6) = "Beskrivelse2"
syncdata(2, 7) = "Footer1"
syncdata(2, 8) = "Karlslunde2"
syncdata(2, 9) = 30
syncdata(2, 10) = "n/a"
syncdata(2, 11) = "n/a"
syncdata(2, 12) = "n/a"
syncdata(2, 13) = "n/a"
syncdata(2, 14) = "n/a"
End Sub

MODUL:
Option Explicit

'Declare progressbar
Dim BMIPROGRESS As New BMIPROC.clsStdDialog

Public Function Outlook_Sync(syncdata() As Variant) As Variant
On Error GoTo Error_Handler

'Declarations
Dim objOutLook As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim ReturnData() As Variant
Dim bError As Boolean
Dim I As Integer
Dim nRecordcount As Integer
Dim nPrc As Integer

'Set the range of the returnarray
ReDim ReturnData(UBound(syncdata), 1)

'Initialize the progressbar
Call BMIPROGRESS.ProgressBar_Initialize("")

'Get recordcount of the array
nRecordcount = UBound(syncdata) + 1

'Travel trought the array of appointments
For I = LBound(syncdata) To UBound(syncdata)

'If = "" then there is no more data
If syncdata(I, 0) = "" Then
Exit For
End If

'Search for the entryid in outlook. Returning the appointment
Set objAppointment = SearchForEntryID(syncdata(I, 1), bError)

'Error returned from search -> Return errorcode 0
If bError Then
ReturnData(I, 0) = syncdata(I, 0)
ReturnData(I, 1) = "0"
Else

If objAppointment Is Nothing Then
'If no such entryid exists in outlook
'Create new appointment object
Set objOutLook = CreateObject("Outlook.Application")

'Create new appoiment item
Set objAppointment = objOutLook.CreateItem(olAppointmentItem)
End If

With objAppointment
'Set the the data
.Start = syncdata(I, 3) & " " & syncdata(I, 4)
.End = syncdata(I, 3) & " " & syncdata(I, 5)

.ReminderSet = True
.ReminderMinutesBeforeStart = syncdata(I, 9)

.Subject = syncdata(I, 2)
.Body = syncdata(I, 6) & vbNewLine & syncdata(I, 8)
.Location = syncdata(I, 7)
.BusyStatus = olBusy

'Save the appointment
.Save

'Set the return recordid and entryid
ReturnData(I, 0) = syncdata(I, 0)
ReturnData(I, 1) = .EntryID
End With
End If

'Calc new prc
nPrc = nPrc + (100 / nRecordcount)

'Update the progressbar
Call BMIPROGRESS.ProgressBar_Update(nPrc, CStr(syncdata(I, 2)))
Next I

'Return the recordID and entryID for each appointment
Outlook_Sync = ReturnData

GoTo Exit_Function
Error_Handler:
'Error reading in an appointment object occured
ReturnData(I, 0) = syncdata(I, 0)
ReturnData(I, 1) = "0"
Resume Next

Exit_Function:
'Remove the progress bar
BMIPROGRESS.ProgressBar_Remove

'Release objects
Set objOutLook = Nothing
Set objAppointment = Nothing
Set BMIPROGRESS = Nothing

End Function

Private Function SearchForEntryID(sEntryID As Variant, bError As Boolean) As
Outlook.AppointmentItem
On Error GoTo Error_Handler

'Declarations
Dim objOutLook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim objAppointment As AppointmentItem
Dim I As Integer

' Get the MAPI name space
Set objNameSpace = objOutLook.GetNamespace("MAPI")

' Get a ref to the folder we want
Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)

' Read through all the items
For I = 1 To objFolder.Items.Count
Set objAppointment = objFolder.Items(I)

' Check the sent date for validity
If objAppointment.EntryID = sEntryID Then

'Return the appointment
Set SearchForEntryID = objAppointment

'Object found exit function
GoTo Exit_Function
End If

Debug.Print objAppointment.EntryID & " - " & objAppointment.CreationTime
Next I

Exit Function
Error_Handler:
'Error occured when contacting outlook
bError = True

Exit_Function:
'Release objects
Set objOutLook = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
Set objAppointment = Nothing
End Function