Re: Missing updates

If this is in Outlook VBA use the intrinsic Application object and don't set
up a new Outlook.Application object.

Macros are public Subs in code modules that have no input arguments.

Do you miss things when a lot of items are deleted at one time? ItemAdd,
ItemRemove and ItemChange only will fire if fewer than 16 items are
added/removed/changed at one time. That's a MAPI limitation that Outlook
code inherits.

If your macro takes a lot of time when it runs then it is conceivable that
you could be missing some events.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:8849CDBB-8136-4C42-A1E1-DD9624415A4A@microsoft.com...
> Hi
> I have some code that copies an appointment from one calendar to a public
> calendar and it works fine when I’m using 2002. When I’m using 2003 and
> have
> disabled macros, it also works fine but if I enable my macro I will miss
> about 5 % of all updates in my own calendar and about 10 % in the public
> calendar. I’m not running my macro in a class module. Could that be the
> reason for missing updates? If so, how much of the macro should be in the
> class module?
>
> Thanks.
> Attached you will find the coding
>
> Option Explicit
> Dim myOlApp As New Outlook.Application
> Public WithEvents CalendarItems As Outlook.Items
> Public WithEvents DeletedItems As Outlook.Items
> Public TOCFolder As Outlook.MAPIFolder
> Public sUser As String
>
> Public Sub Initialize_handler()
> sUser = "BOH "
> Set CalendarItems = myOlApp.GetNamespace("MAPI"). _
> GetDefaultFolder(olFolderCalendar).Items
> Set DeletedItems = myOlApp.GetNamespace("MAPI"). _
> GetDefaultFolder(olFolderDeletedItems).Items
> Set TOCFolder = GetFolder("Public Folders\All Public Folders…….")
> If TOCFolder Is Nothing Then
> Set TOCFolder = GetFolder("………………")
> End If
> End Sub
>
> Private Sub Application_Startup()
> Initialize_handler
> End Sub
>
> Private Sub DeletedItems_Itemadd(ByVal Item As Object)
> Dim OCalItem As Outlook.AppointmentItem
> Dim OStr As String
> On Error Resume Next
> 'MsgBox ("ItemDel")
> If TOCFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> Else
> OStr = "[Item]='" & Item & "'"
> 'MsgBox OStr
> Set OCalItem = TOCFolder.Items.Find("[BillingInformation]='" &
> Item.BillingInformation & "'")
> If TypeName(OCalItem) <> "Nothing" Then
> OCalItem.Delete
> End If
> End If
> Set OCalItem = Nothing
> End Sub
>
> Private Sub CalendarItems_Itemadd(ByVal Item As Object)
> Dim myAppt As Outlook.AppointmentItem
> Dim myStr As String
> On Error Resume Next
> 'MsgBox ("ItemAdd")
> Item.BillingInformation = Item.LastModificationTime
> Item.Save
> Set myAppt = TOCFolder.Items.Add(Outlook.OlItemType.olAppointmentItem)
> myAppt = Item
> myAppt.Duration = Item.Duration
> myAppt.Sensitivity = Item.Sensitivity
> If TOCFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> Else
> If myAppt.Class <> olAppointment Then
> ' MsgBox myAppt.Class
> ' ElseIf myAppt.Sensitivity = olPrivate Then
> ElseIf myAppt.Duration >= 240 Then
> Set myAppt = Nothing
> Set myAppt = Item.Copy
> If myAppt.Sensitivity <> olPrivate Then
> myAppt.Subject = sUser & Item.Subject
> Else
> myAppt.Subject = sUser & "Privat"
> myAppt.Location = ""
> End If
> myAppt.ReminderSet = False
> myAppt.Move TOCFolder
> End If
> End If
> Set myAppt = Nothing
> End Sub
>
> Private Sub CalendarItems_Itemchange(ByVal Item As Object)
> Dim mychgAppt As Outlook.AppointmentItem
> Dim OCalItem As Outlook.AppointmentItem
> Dim OStr As String
> On Error Resume Next
> 'MsgBox ("ItemChange")
> If TOCFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> Else
> OStr = "[Item]='" & Item & "'"
> 'MsgBox OStr
> Set OCalItem = TOCFolder.Items.Find("[BillingInformation]='" &
> Item.BillingInformation & "'")
> If TypeName(OCalItem) <> "Nothing" Then
> OCalItem.Delete
> End If
> Set mychgAppt =
> TOCFolder.Items.Add(Outlook.OlItemType.olAppointmentItem)
> mychgAppt = Item
> mychgAppt.Duration = Item.Duration
> mychgAppt.Sensitivity = Item.Sensitivity
> If mychgAppt.Class <> olAppointment Then
> ' ElseIf mychgAppt.Sensitivity = olPrivate Then
> ' Set mychgAppt = Nothing
> ElseIf mychgAppt.Duration >= 240 Then
> Set mychgAppt = Nothing
> Set mychgAppt = Item.Copy
> If mychgAppt.Sensitivity <> olPrivate Then
> mychgAppt.Subject = sUser & Item.Subject
> Else
> mychgAppt.Subject = sUser & "Privat"
> mychgAppt.Location = ""
> End If
> mychgAppt.ReminderSet = False
> mychgAppt.Move TOCFolder
> ' MsgBox "Delete"
> End If
> Set mychgAppt = Nothing
> End If
> Set mychgAppt = Nothing
> Set OCalItem = Nothing
> End Sub
>

Using Application wouldn't solve a problem of missing events, it just uses
the trusted Application object and is a good practice for all Outlook VBA
code.

You should not miss events when Outlook is updating the status bar and
waiting for a time between making a change and saving it should also not be
a factor. I'd probably comment out all my macro code and just write a debug
statement using Debug.Print to make sure the event handler was being called
first. Then after that got running I'd start in on why sometimes the event
was missed.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:C0CDA94D-6B61-4988-88D8-31C45695C475@microsoft.com...
> Hi Ken
> Thanks for your answer.
>
> I have removed “Dim myOlapp As New Outlook.Application” and replaced
> myOlApp
> with Application throughout. OK? The problem is still there.
>
> I’m missing things when I click an appointment in my calendar, then move
> the
> start- or end-time and then click beside the appointment to save it. If
> the
> time between moving and clicking is less than 2 – 3 seconds, the
> ChangeItem
> event will not fire in about 5% of all attempts.
> I think only one item is changed at one time and none of my macros are
> running when the event should fire.
>
> I have used a date in the past for testing and I get “This appointment
> occurs in the past” in the bottom of the calendar. I think, but can’t
> prove
> it, that if I save my appointment during the time outlook is writing in
> the
> bottom of the calendar, then I will miss things?!?
>
> boh

The Item.Copy function will always copy the item to the source folder of the
item. You can set up a flag that's set when you copy the item so you ignore
the next change event.

If you're using a lower level API such as CDO 1.21 or Redemption you can use
Message.CopyTo (CDO) or Safe*Item.CopyTo or RDOMail.CopyTo (both from
Redemption) to avoid the copy to the source folder.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:C5B78324-9EF0-43B3-A085-3BA4F5087C90@microsoft.com...
> Hi Ken
>
> I did as you said. When all my macro is comment out, I get debug prints as
> wanted. I can see I’m doing some mistake when moving an item around. I
> want
> to copy the item which is argument to ItemChange to the public folder,
> then
> change some objects and save the appointment in the public folder but I
> can’t
> figure out how to do. My copy stores in my local folder which means I get
> another ItemAdd event. Please HELP.
>
> boh

Of course you can trap an error in code. Just use an error handler or set On
Error Resume Next and test the Err object after every operation that might
throw an error. If in doubt clear the Err object before performing the
operation so you know it's clear before you start.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:A8912733-72AC-42C1-BC68-28308285C003@microsoft.com...
> "Hi
> I have comment out the statement "On Error Resume Next" and added a
> statement If Item.Class = olAppointment Then" do the stuff . It works fine
> the first time and Debug.Print "ItemChange Item = " & Item -> "ItemChange
> Item = Test" but when the macro runs for the 2'nd time I get an run-time
> error '-2147221233 (800401f)':Automation error. I think I have to do a
> better
> check of the Item object before I use it but how? I think the appointment
> that fires the event is moved to the public folder during the 1'st run of
> the
> macro and thats why I get problems. Is it possible to trap a error with
> code?
> If yes, how do I do?
> Thanks / boh

Thanks for your answer.

I have added some tests and debug.prints but the main problem remains.

If I open an appointment, change the end-time and click "Save and close"
everything works fine. Always.

If I open the appointment by clicking the appointment, then drag the
end-time and click beside to close, then the ItemChange event will not fire
every second occasion. I have never seen two consecutive updates missing.

If I open the appointment after a missing update, the correct end-time shows
up. As I can see, the only missing thing is: the Itemchange event will not
fire!

Any thoughts about what needs to be done here?

Thanks / boh

"Ken Slovak - [MVP - Outlook]" skrev:

> Of course you can trap an error in code. Just use an error handler or set On
> Error Resume Next and test the Err object after every operation that might
> throw an error. If in doubt clear the Err object before performing the
> operation so you know it's clear before you start.
>
> --
> Ken Slovak
> [MVP - Outlook]
> http://www.slovaktech.com
> Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
> Reminder Manager, Extended Reminders, Attachment Options
> http://www.slovaktech.com/products.htm
>
>
> "boh" <boh@discussions.microsoft.com> wrote in message
> news:A8912733-72AC-42C1-BC68-28308285C003@microsoft.com...
> > "Hi
> > I have comment out the statement "On Error Resume Next" and added a
> > statement If Item.Class = olAppointment Then" do the stuff . It works fine
> > the first time and Debug.Print "ItemChange Item = " & Item -> "ItemChange
> > Item = Test" but when the macro runs for the 2'nd time I get an run-time
> > error '-2147221233 (800401f)':Automation error. I think I have to do a
> > better
> > check of the Item object before I use it but how? I think the appointment
> > that fires the event is moved to the public folder during the 1'st run of
> > the
> > macro and thats why I get problems. Is it possible to trap a error with
> > code?
> > If yes, how do I do?
> > Thanks / boh
>
>

What do you mean by "drag the end time"?

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:C260D686-94A3-4A61-9033-6A8D04BBC257@microsoft.com...
> Thanks for your answer.
>
> I have added some tests and debug.prints but the main problem remains.
>
> If I open an appointment, change the end-time and click "Save and close"
> everything works fine. Always.
>
> If I open the appointment by clicking the appointment, then drag the
> end-time and click beside to close, then the ItemChange event will not
> fire
> every second occasion. I have never seen two consecutive updates missing.
>
> If I open the appointment after a missing update, the correct end-time
> shows
> up. As I can see, the only missing thing is: the Itemchange event will not
> fire!
>
> Any thoughts about what needs to be done here?
>
> Thanks / boh

I'm sorry, but I can't repro that here. If I drag an appointment's end time
using the mouse in an Explorer view then as soon as the focus moves to a
different item or the changed appointment isn't selected for in-cell editing
the change is committed and I get an ItemChange event.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:2C59A36B-26E4-4127-8FB8-C36E5240FE57@microsoft.com...
> In the calendar view, I put the cursor on the bottom of the appointment,
> hold
> the left mouse key down and drag the mouse down, say an hour, and then
> release the mouse key. Then I move the mouse outside the appointment and
> click.
>
> Sorry for my English but I hope you can understand what I mean.
> / boh

If I disable my macro, everything works OK. But when I enable the following
code, the problem starts. In other words: I'm doing something wrong in my
macro.
/boh

Option Explicit
Public TocFolder As Outlook.MAPIFolder
Public WithEvents CalendarItems As Outlook.Items
Public WithEvents DeletedItems As Outlook.Items
Public sUser As String

Public Sub Initialize_handler()
sUser = "BOH "
Set CalendarItems = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderCalendar).Items
Set DeletedItems = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems).Items
' Path to public folder
Set TocFolder = GetFolder("Public Folders\All Public Folders\......TOC")
If TocFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
End If
End Sub

Private Sub Application_Startup()
Initialize_handler
End Sub

Private Sub DeletedItems_Itemadd(ByVal Item As Object)
Dim OCalItem As Outlook.AppointmentItem
Dim PalmFolder As Outlook.Folders
Dim OStr As String
On Error Resume Next
'MsgBox ("ItemDel")
If TocFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
ElseIf Item.Class = olAppointment Then
OStr = "[Item]='" & Item & "'"
'MsgBox OStr
Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
Item.BillingInformation & "'")
If TypeName(OCalItem) <> "Nothing" Then
OCalItem.Delete
End If
End If
Set OCalItem = Nothing
End Sub

Private Sub CalendarItems_Itemadd(ByVal Item As Object)
Dim myAppt As Outlook.AppointmentItem
Dim OCalItem As Outlook.AppointmentItem
Dim myStr As String
On Error Resume Next
'MsgBox ("ItemAdd")
'If Flag Then GoTo Out
If Item.Class = olAppointment Then
Err.Clear
Item.BillingInformation = Item.LastModificationTime
If Err.Number <> 0 Then GoTo Out
Item.Save
Debug.Print "ItemAdd [Item) = " & Item
If TocFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
Else
Call App1(Item)
End If
End If
Out:
Set myAppt = Nothing
Set OCalItem = Nothing
End Sub

Private Sub CalendarItems_Itemchange(ByVal Item As Object)
Dim myAppt As Outlook.AppointmentItem
Dim OCalItem As Outlook.AppointmentItem
Dim PalmFolder As Outlook.Folders
Dim OPalmFolder As Outlook.MAPIFolder
Dim OStr As String
On Error Resume Next
'If Flag Then GoTo Out
If Item.Class = olAppointment Then
Err.Clear
Debug.Print "ItemChange Item = " & Item
If Err.Number <> 0 Then GoTo Out
If TocFolder Is Nothing Then
MsgBox "Can´t get the folder TOC"
Else
'OStr = "[Item]='" & Item & "'"
'MsgBox OStr
'Debug.Print OStr
Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
Item.BillingInformation & "'")
If TypeName(OCalItem) <> "Nothing" Then
OCalItem.Delete
End If
Call App1(Item)
End If
Set myAppt = Nothing
Else
' Debug.Print Item.Class
End If
Out:
Debug.Print "ItemChange out "
Set myAppt = Nothing
Set OPalmFolder = Nothing
Set OCalItem = Nothing
End Sub

Sub App1(ByVal Item)
Dim myAppt As Outlook.AppointmentItem
'Set myAppt = TocFolder.Items.Add(Outlook.OlItemType.olAppointmentItem)

If Item.Duration >= 240 Then
Set myAppt = Item.Copy
If myAppt.Sensitivity <> olPrivate Then
myAppt.Subject = sUser & Item.Subject
Else
myAppt.Subject = sUser & "Privat"
myAppt.Location = ""
End If
myAppt.ReminderSet = False
myAppt.Save
myAppt.Move TocFolder
End If
Set myAppt = Nothing
End Sub


Function GetFolder(FolderPath)
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim aFolders
Dim strFolderPath
Dim fldr As MAPIFolder
Dim i
Dim objNS

On Error Resume Next
strFolderPath = Replace(FolderPath, "/", "\")
aFolders = Split(FolderPath, "\")

'get the Outlook objects
' use intrinsic Application object in form script
Set objNS = Application.GetNamespace("MAPI")

'set the root folder
Set fldr = objNS.Folders(aFolders(0))

'loop through the array to get the subfolder
'loop is skipped when there is only one element in the array
For i = 1 To UBound(aFolders)
Set fldr = fldr.Folders(aFolders(i))
'check for errors
If Err <> 0 Then Exit Function
Next
Set GetFolder = fldr

' dereference objects
Set objNS = Nothing
End Function

"Ken Slovak - [MVP - Outlook]" skrev:

> I'm sorry, but I can't repro that here. If I drag an appointment's end time
> using the mouse in an Explorer view then as soon as the focus moves to a
> different item or the changed appointment isn't selected for in-cell editing
> the change is committed and I get an ItemChange event.
>
> --
> Ken Slovak
> [MVP - Outlook]
> http://www.slovaktech.com
> Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
> Reminder Manager, Extended Reminders, Attachment Options
> http://www.slovaktech.com/products.htm
>
>
> "boh" <boh@discussions.microsoft.com> wrote in message
> news:2C59A36B-26E4-4127-8FB8-C36E5240FE57@microsoft.com...
> > In the calendar view, I put the cursor on the bottom of the appointment,
> > hold
> > the left mouse key down and drag the mouse down, say an hour, and then
> > release the mouse key. Then I move the mouse outside the appointment and
> > click.
> >
> > Sorry for my English but I hope you can understand what I mean.
> > / boh
>
>

Your logic is causing a loop of ItemAdd and ItemChange events to fire within
the existing event handlers. That's a very good reason to miss some events,
especially because you're trying to force a failure by doing changes very
quickly and using code that takes a little time within the event handlers.

A general rule of thumb for coding microprocessors is not to force one
interrupt service routine to take too long or to force another or the same
interrupt service routine to fire itself. It's a formula for missing things.

Either store the EntryID and StoreID of the items to move/copy within the
event handler and set a timer to fire a couple of seconds later to pick up
the item or items, or use a different API such as CDO 1.21 or Redemption to
have a CopyTo method that doesn't copy the original item to the same folder.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"boh" <boh@discussions.microsoft.com> wrote in message
news:2FCCE3C3-4794-4B59-90DC-ECECA4DB7554@microsoft.com...
> If I disable my macro, everything works OK. But when I enable the
> following
> code, the problem starts. In other words: I'm doing something wrong in my
> macro.
> /boh
>
> Option Explicit
> Public TocFolder As Outlook.MAPIFolder
> Public WithEvents CalendarItems As Outlook.Items
> Public WithEvents DeletedItems As Outlook.Items
> Public sUser As String
>
> Public Sub Initialize_handler()
> sUser = "BOH "
> Set CalendarItems = Application.GetNamespace("MAPI"). _
> GetDefaultFolder(olFolderCalendar).Items
> Set DeletedItems = Application.GetNamespace("MAPI"). _
> GetDefaultFolder(olFolderDeletedItems).Items
> ' Path to public folder
> Set TocFolder = GetFolder("Public Folders\All Public Folders\......TOC")
> If TocFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> End If
> End Sub
>
> Private Sub Application_Startup()
> Initialize_handler
> End Sub
>
> Private Sub DeletedItems_Itemadd(ByVal Item As Object)
> Dim OCalItem As Outlook.AppointmentItem
> Dim PalmFolder As Outlook.Folders
> Dim OStr As String
> On Error Resume Next
> 'MsgBox ("ItemDel")
> If TocFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> ElseIf Item.Class = olAppointment Then
> OStr = "[Item]='" & Item & "'"
> 'MsgBox OStr
> Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
> Item.BillingInformation & "'")
> If TypeName(OCalItem) <> "Nothing" Then
> OCalItem.Delete
> End If
> End If
> Set OCalItem = Nothing
> End Sub
>
> Private Sub CalendarItems_Itemadd(ByVal Item As Object)
> Dim myAppt As Outlook.AppointmentItem
> Dim OCalItem As Outlook.AppointmentItem
> Dim myStr As String
> On Error Resume Next
> 'MsgBox ("ItemAdd")
> 'If Flag Then GoTo Out
> If Item.Class = olAppointment Then
> Err.Clear
> Item.BillingInformation = Item.LastModificationTime
> If Err.Number <> 0 Then GoTo Out
> Item.Save
> Debug.Print "ItemAdd [Item) = " & Item
> If TocFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> Else
> Call App1(Item)
> End If
> End If
> Out:
> Set myAppt = Nothing
> Set OCalItem = Nothing
> End Sub
>
> Private Sub CalendarItems_Itemchange(ByVal Item As Object)
> Dim myAppt As Outlook.AppointmentItem
> Dim OCalItem As Outlook.AppointmentItem
> Dim PalmFolder As Outlook.Folders
> Dim OPalmFolder As Outlook.MAPIFolder
> Dim OStr As String
> On Error Resume Next
> 'If Flag Then GoTo Out
> If Item.Class = olAppointment Then
> Err.Clear
> Debug.Print "ItemChange Item = " & Item
> If Err.Number <> 0 Then GoTo Out
> If TocFolder Is Nothing Then
> MsgBox "Can´t get the folder TOC"
> Else
> 'OStr = "[Item]='" & Item & "'"
> 'MsgBox OStr
> 'Debug.Print OStr
> Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
> Item.BillingInformation & "'")
> If TypeName(OCalItem) <> "Nothing" Then
> OCalItem.Delete
> End If
> Call App1(Item)
> End If
> Set myAppt = Nothing
> Else
> ' Debug.Print Item.Class
> End If
> Out:
> Debug.Print "ItemChange out "
> Set myAppt = Nothing
> Set OPalmFolder = Nothing
> Set OCalItem = Nothing
> End Sub
>
> Sub App1(ByVal Item)
> Dim myAppt As Outlook.AppointmentItem
> 'Set myAppt = TocFolder.Items.Add(Outlook.OlItemType.olAppointmentItem)
>
> If Item.Duration >= 240 Then
> Set myAppt = Item.Copy
> If myAppt.Sensitivity <> olPrivate Then
> myAppt.Subject = sUser & Item.Subject
> Else
> myAppt.Subject = sUser & "Privat"
> myAppt.Location = ""
> End If
> myAppt.ReminderSet = False
> myAppt.Save
> myAppt.Move TocFolder
> End If
> Set myAppt = Nothing
> End Sub
>
>
> Function GetFolder(FolderPath)
> ' folder path needs to be something like
> ' "Public Folders\All Public Folders\Company\Sales"
> Dim aFolders
> Dim strFolderPath
> Dim fldr As MAPIFolder
> Dim i
> Dim objNS
>
> On Error Resume Next
> strFolderPath = Replace(FolderPath, "/", "\")
> aFolders = Split(FolderPath, "\")
>
> 'get the Outlook objects
> ' use intrinsic Application object in form script
> Set objNS = Application.GetNamespace("MAPI")
>
> 'set the root folder
> Set fldr = objNS.Folders(aFolders(0))
>
> 'loop through the array to get the subfolder
> 'loop is skipped when there is only one element in the array
> For i = 1 To UBound(aFolders)
> Set fldr = fldr.Folders(aFolders(i))
> 'check for errors
> If Err <> 0 Then Exit Function
> Next
> Set GetFolder = fldr
>
> ' dereference objects
> Set objNS = Nothing
> End Function

Hi again!

I have included CDO in Outlook but I can't get copyto working. Please, do
you have a piece of code showing how to copy the Item object, parameter to
Itemchange event, to public folder? Thanks / boh

"boh" skrev:

> Thank you very much / boh
>
> "Ken Slovak - [MVP - Outlook]" skrev:
>
> > Your logic is causing a loop of ItemAdd and ItemChange events to fire within
> > the existing event handlers. That's a very good reason to miss some events,
> > especially because you're trying to force a failure by doing changes very
> > quickly and using code that takes a little time within the event handlers.
> >
> > A general rule of thumb for coding microprocessors is not to force one
> > interrupt service routine to take too long or to force another or the same
> > interrupt service routine to fire itself. It's a formula for missing things.
> >
> > Either store the EntryID and StoreID of the items to move/copy within the
> > event handler and set a timer to fire a couple of seconds later to pick up
> > the item or items, or use a different API such as CDO 1.21 or Redemption to
> > have a CopyTo method that doesn't copy the original item to the same folder.
> >
> > --
> > Ken Slovak
> > [MVP - Outlook]
> > http://www.slovaktech.com
> > Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
> > Reminder Manager, Extended Reminders, Attachment Options
> > http://www.slovaktech.com/products.htm
> >
> >
> > "boh" <boh@discussions.microsoft.com> wrote in message
> > news:2FCCE3C3-4794-4B59-90DC-ECECA4DB7554@microsoft.com...
> > > If I disable my macro, everything works OK. But when I enable the
> > > following
> > > code, the problem starts. In other words: I'm doing something wrong in my
> > > macro.
> > > /boh
> > >
> > > Option Explicit
> > > Public TocFolder As Outlook.MAPIFolder
> > > Public WithEvents CalendarItems As Outlook.Items
> > > Public WithEvents DeletedItems As Outlook.Items
> > > Public sUser As String
> > >
> > > Public Sub Initialize_handler()
> > > sUser = "BOH "
> > > Set CalendarItems = Application.GetNamespace("MAPI"). _
> > > GetDefaultFolder(olFolderCalendar).Items
> > > Set DeletedItems = Application.GetNamespace("MAPI"). _
> > > GetDefaultFolder(olFolderDeletedItems).Items
> > > ' Path to public folder
> > > Set TocFolder = GetFolder("Public Folders\All Public Folders\......TOC")
> > > If TocFolder Is Nothing Then
> > > MsgBox "Can´t get the folder TOC"
> > > End If
> > > End Sub
> > >
> > > Private Sub Application_Startup()
> > > Initialize_handler
> > > End Sub
> > >
> > > Private Sub DeletedItems_Itemadd(ByVal Item As Object)
> > > Dim OCalItem As Outlook.AppointmentItem
> > > Dim PalmFolder As Outlook.Folders
> > > Dim OStr As String
> > > On Error Resume Next
> > > 'MsgBox ("ItemDel")
> > > If TocFolder Is Nothing Then
> > > MsgBox "Can´t get the folder TOC"
> > > ElseIf Item.Class = olAppointment Then
> > > OStr = "[Item]='" & Item & "'"
> > > 'MsgBox OStr
> > > Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
> > > Item.BillingInformation & "'")
> > > If TypeName(OCalItem) <> "Nothing" Then
> > > OCalItem.Delete
> > > End If
> > > End If
> > > Set OCalItem = Nothing
> > > End Sub
> > >
> > > Private Sub CalendarItems_Itemadd(ByVal Item As Object)
> > > Dim myAppt As Outlook.AppointmentItem
> > > Dim OCalItem As Outlook.AppointmentItem
> > > Dim myStr As String
> > > On Error Resume Next
> > > 'MsgBox ("ItemAdd")
> > > 'If Flag Then GoTo Out
> > > If Item.Class = olAppointment Then
> > > Err.Clear
> > > Item.BillingInformation = Item.LastModificationTime
> > > If Err.Number <> 0 Then GoTo Out
> > > Item.Save
> > > Debug.Print "ItemAdd [Item) = " & Item
> > > If TocFolder Is Nothing Then
> > > MsgBox "Can´t get the folder TOC"
> > > Else
> > > Call App1(Item)
> > > End If
> > > End If
> > > Out:
> > > Set myAppt = Nothing
> > > Set OCalItem = Nothing
> > > End Sub
> > >
> > > Private Sub CalendarItems_Itemchange(ByVal Item As Object)
> > > Dim myAppt As Outlook.AppointmentItem
> > > Dim OCalItem As Outlook.AppointmentItem
> > > Dim PalmFolder As Outlook.Folders
> > > Dim OPalmFolder As Outlook.MAPIFolder
> > > Dim OStr As String
> > > On Error Resume Next
> > > 'If Flag Then GoTo Out
> > > If Item.Class = olAppointment Then
> > > Err.Clear
> > > Debug.Print "ItemChange Item = " & Item
> > > If Err.Number <> 0 Then GoTo Out
> > > If TocFolder Is Nothing Then
> > > MsgBox "Can´t get the folder TOC"
> > > Else
> > > 'OStr = "[Item]='" & Item & "'"
> > > 'MsgBox OStr
> > > 'Debug.Print OStr
> > > Set OCalItem = TocFolder.Items.Find("[BillingInformation]='" &
> > > Item.BillingInformation & "'")
> > > If TypeName(OCalItem) <> "Nothing" Then
> > > OCalItem.Delete
> > > End If
> > > Call App1(Item)
> > > End If
> > > Set myAppt = Nothing
> > > Else
> > > ' Debug.Print Item.Class
> > > End If
> > > Out:
> > > Debug.Print "ItemChange out "
> > > Set myAppt = Nothing
> > > Set OPalmFolder = Nothing
> > > Set OCalItem = Nothing
> > > End Sub
> > >
> > > Sub App1(ByVal Item)
> > > Dim myAppt As Outlook.AppointmentItem
> > > 'Set myAppt = TocFolder.Items.Add(Outlook.OlItemType.olAppointmentItem)
> > >
> > > If Item.Duration >= 240 Then
> > > Set myAppt = Item.Copy
> > > If myAppt.Sensitivity <> olPrivate Then
> > > myAppt.Subject = sUser & Item.Subject
> > > Else
> > > myAppt.Subject = sUser & "Privat"
> > > myAppt.Location = ""
> > > End If
> > > myAppt.ReminderSet = False
> > > myAppt.Save
> > > myAppt.Move TocFolder
> > > End If
> > > Set myAppt = Nothing
> > > End Sub
> > >
> > >
> > > Function GetFolder(FolderPath)
> > > ' folder path needs to be something like
> > > ' "Public Folders\All Public Folders\Company\Sales"
> > > Dim aFolders
> > > Dim strFolderPath
> > > Dim fldr As MAPIFolder
> > > Dim i
> > > Dim objNS
> > >
> > > On Error Resume Next
> > > strFolderPath = Replace(FolderPath, "/", "\")
> > > aFolders = Split(FolderPath, "\")
> > >
> > > 'get the Outlook objects
> > > ' use intrinsic Application object in form script
> > > Set objNS = Application.GetNamespace("MAPI")
> > >
> > > 'set the root folder
> > > Set fldr = objNS.Folders(aFolders(0))
> > >
> > > 'loop through the array to get the subfolder
> > > 'loop is skipped when there is only one element in the array
> > > For i = 1 To UBound(aFolders)
> > > Set fldr = fldr.Folders(aFolders(i))
> > > 'check for errors
> > > If Err <> 0 Then Exit Function
> > > Next
> > > Set GetFolder = fldr
> > >
> > > ' dereference objects
> > > Set objNS = Nothing
> > > End Function
> >
> >