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
|