Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 782
  • Last Modified:

Need help with this macro code

I have this macro bode, which supposed to move items from one folder to another in outlook.

is it possible to make some changes to it and make it move calendar items from a PST, which is opened in outlook to a folder in the mailbox, which stores calendar items?

if so what changes need to be made?

any help is much appreciated.

Code Starts:

Sub MoveSelectedMessagesToToDo()

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

   ' MUST CHANGE THE OUTPUT FOLDER
   ' Assume this is a mail folder
    Set objFolder = GetFolder("10_Offline\_00_to_do")
    ' In case you would like to move to a subfolder in the inbox
    'Set objFolder = objInbox.Folders.Item("Done")


    If objFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If

    If Application.ActiveExplorer.Selection.Count = 0 Then
        'Require that this procedure be called only when a message is selected
        Exit Sub
    End If

 
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move objFolder
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub



Sub MoveSelectedMessagesToFolder()

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

   ' MUST CHANGE THE OUTPUT FOLDER
   ' Assume this is a mail folder
    Set objFolder = GetFolder("2009\Q4")
   


    If objFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If

    If Application.ActiveExplorer.Selection.Count = 0 Then
         MsgBox "Nothing selected", vbOKOnly + vbExclamation, "No message selected"
        Exit Sub
    End If

 
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move objFolder
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' folder path needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

Code Ends:
0
Medquest
Asked:
Medquest
  • 66
  • 64
  • 4
  • +1
2 Solutions
 
Chris BottomleyCommented:
MOve calendar items between folders.

At the moment the script is locked to mailitems, and whilst this should be easy to open up, it also has teh folders embedded in teh script.  It may be simpler therefore simply to have a new script for the calendar item movements?

If this is ok then can you confirm the process i.e.:

For each item selectged in the current folder
    Check it's a calendar item
        Move it to a pre-defined folder
next

If yes then what is the path for the moveto folder ... and does it pre-exist ... (if so this simplifies the coding).

Chris
0
 
MedquestAuthor Commented:
Chris,
I agree with you.
I am trying to keep to folders in sync. one folder is stored on a PST file (sharepoint list) and the folder name for now let's just say Test Calendar, and then the other folder which is in the mailbox, which is let's say for now Smith, Joe and the folder name also Test Calendar.
 
normally the items will get to the one on the PST file, and need them to be copied to the one on the mailbox.
is this possible?
Thanks
 
0
 
Chris BottomleyCommented:
JUst for a moment can I continue to ignore the previous code:

What we can do is set an event handler so as soon as something is added to the 'first' folder it is copied to the 'second' one.

THis takes a trivial amount of code as long as all original posts goto the one folder.

Chris
0
NFR key for Veeam Agent for Linux

Veeam is happy to provide a free NFR license for one year.  It allows for the non‑production use and valid for five workstations and two servers. Veeam Agent for Linux is a simple backup tool for your Linux installations, both on‑premises and in the public cloud.

 
MedquestAuthor Commented:
sure thing, let's forget about the previous code.
 
how can we create such an event handler?
0
 
Chris BottomleyCommented:
There are three code components for each 'folder' as such, all code in thisOutlookSession:

1. INitialise a collection at the top of the module just after any option statements:

Private WithEvents olkCalendar As Outlook.items

2. Instantiate the collection in the outlook startup:

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items

End Sub

3. IMplement the chosen activity

Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

    Set itmCopy = itm.Copy
    itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar).folders("CopyCal")

End Sub

Chris
0
 
MedquestAuthor Commented:
so what would be the final code based on the information I provided, which I am going to change folder names and such?
0
 
Chris BottomleyCommented:
Not sure I follow so perhaps a clone will suggest the interpretation ... if not then can you rephrase what you need explaining:


Private WithEvents olkCalendar As Outlook.items
Private WithEvents olkInbox As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items
    Set olkInbox = Session.GetDefaultFolder(olFolderInbox).items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object
    Set itmCopy = itm.Copy
    itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar).folders("CopyCal")
End Sub

Sub olkInbox_ItemAdd(ByVal Item As Object)
dim itmCopy as object
    Set itmCopy = itm.Copy
    itmCopy.Move Application.Session.GetDefaultFolder(olFolder).folders("CopyInbox")
End Sub

 

Open in new window

0
 
MedquestAuthor Commented:
I am trying to keep 2 calendars in sync, where I would create an item in one of them and it would get copied to the other one, because the one in the mailbox can be seen in blackberry and the other one is stored in a PST and can ben seen only in outlook.
just like the 2 calendars you see in the attached image.

Calendar-Sync.jpg
0
 
Chris BottomleyCommented:
Can you pop the cursor onto the calendartestpst folder then in the BE immediate window, (ctrl + G to display it) enter:

?application.ActiveExplorer.CurrentFolder.FolderPath

Letting me know what it says?

Chris
0
 
MedquestAuthor Commented:
I am not really sure I understand what you're asking me to do :)
0
 
Chris BottomleyCommented:
You provided a snippet showing the calendars in teh outlook folders window.

In order to accurately capture that structure I need the folder path.  I can accurately get that from you via a bit of VBA.

1. IN outlook select the calendarTestPST folder.
2. IN outlook select the VBE using alt + F11
3. IN the VBE select the immediate window using ctrl + G
4. In the immediate window, (header bar immediate) place the line of code:
?application.ActiveExplorer.CurrentFolder.FolderPath
5. Select enter on the line and a string should be displayed ... copy that string here.

Chris
0
 
MedquestAuthor Commented:
I had to enable macros for this to work, and I hope it's what you were asking for.
Thanks
 
\\SharePoint Lists\CalendarTestPST
0
 
Chris BottomleyCommented:
The following should copy any entry in the calendar into that sharepoint folder.

Recall it's all located in thisOutlookSession and there should only be one copy.

Chris
Private WithEvents olkCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object
    Set itmCopy = itm.Copy
    itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")

End Sub

Open in new window

0
 
MedquestAuthor Commented:
so do I need two macros one copyes from:
\\Mailbox - Smith, Joe\CalendarTestMBX
to
\\SharePoint Lists\CalendarTestPST and then the other one copys from:
\\SharePoint Lists\CalendarTestPST to \\Mailbox - Smith, Joe\CalendarTestMBX
to
\\SharePoint Lists\CalendarTestPST
 
so this way both folders will have the same contents?
0
 
Chris BottomleyCommented:
Unless i'm missing teh point ... not a good idea to copy from a to b and b to a as well since each time an item is dropped in place the reverse process will occur.

But the text is slightly confusing and you might not mean that so can you double check what you said in the last post?
0
 
MedquestAuthor Commented:
I agree it's confusing, but the point I am trying to reach here is to keep the contents in both folders the same at all times, and that's why I was copying from A to B and then from B to A to achieve this goal.
is there a better way to do that?
0
 
Chris BottomleyCommented:
I think we can do something with a hack ... let me think awhile.

Chris
0
 
MedquestAuthor Commented:
I really appreicate your help.
 
Thanks Chris
0
 
Chris BottomleyCommented:
PAste the following sub into a normal code module.

Now Open a calendar item from the normal calendar and run the macro ... do you get a prompt true?

If so we can probably use this field to work with ... and we'll double check that later.

Chris
Sub addUSerProp()
Dim calItem As AppointmentItem

    Set calItem = Application.ActiveInspector.CurrentItem.Copy
    calItem.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    If Not hasProp(calItem, "CopyRecord") Then _
        calItem.UserProperties.Add "CopyRecord", olYesNo
    calItem.UserProperties("CopyRecord").Value = True
    MsgBox calItem.UserProperties("CopyRecord") = True
    
End Sub

Open in new window

0
 
MedquestAuthor Commented:
I don't think it liked this all that much :)
Error1.jpg
Error2.jpg
0
 
Chris BottomleyCommented:
Oops .. should have included that ... post it into the same module.

Chris
Function hasProp(item As Object, strPropertyName As String) As Boolean
Dim prop As Variant

    For Each prop In item.UserProperties
        If LCase(prop.Name) = LCase(strPropertyName) Then
            hasProp = True
            Exit For
        End If
    Next
End Function

Open in new window

0
 
MedquestAuthor Commented:
Chris,
I've had a long day already and I amn not really sure what do you want me to do with the code now.
can you tell me again please?
 
Thanks
 
0
 
Chris BottomleyCommented:
add it after addUSerProp and run addUSerProp again:

Now Open a calendar item from the normal calendar and run the macro ... do you get a prompt true?

Chris
0
 
MedquestAuthor Commented:
I just tried this and I didn't get the prompt.
 
 
0
 
Chris BottomleyCommented:
Okay then, we can't use useproperties.  Tomorrow we'll try something else!

Chris
0
 
MedquestAuthor Commented:
sounds good.
thanks for all your help.
0
 
Chris BottomleyCommented:
That said I have just tried a resequencing as perhaps it's version dependant.

Replace the previous sub addUSerProp with this new one and try again ... tomorrow is fine!

BTW which version of outlook are you using?

Chris


Sub addUSerProp()
Dim calItem As AppointmentItem

    Set calItem = Application.ActiveInspector.CurrentItem.Copy
    If Not hasProp(calItem, "CopyRecord") Then _
        calItem.UserProperties.Add "CopyRecord", olYesNo
    calItem.UserProperties("CopyRecord").Value = True
    calItem.Move Application.Session.GetDefaultFolder(olFolderCalendar).folders("copycal")
    MsgBox calItem.UserProperties("CopyRecord") = True
    
End Sub

Open in new window

0
 
MedquestAuthor Commented:
I am running outlook 2010 and the client comupters are running 2007 (mostly)
could you please give me the exact steps I need to do to make this test as accurate as possible?
 
Thanks
 
0
 
Chris BottomleyCommented:
There was a bug in the last one so ...

1. Replace the current sub addUSerProp with this new one and then ...
2. Open a calendar item from the normal calendar and run the macro addUSerProp  ... do you get a prompt true?

Chris
Sub addUSerProp()
Dim calItem As AppointmentItem

    Set calItem = Application.ActiveInspector.CurrentItem.Copy
    If Not hasProp(calItem, "CopyRecord") Then _
        calItem.UserProperties.Add "CopyRecord", olYesNo
    calItem.UserProperties("CopyRecord").Value = True
    calItem.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    MsgBox calItem.UserProperties("CopyRecord") = True
    
End Sub

Open in new window

0
 
MedquestAuthor Commented:
I get this error:
Compiler error:
Sub or Function not defined.
0
 
Chris BottomleyCommented:
Did you delete hasProp?

Chris
Function hasProp(item As Object, strPropertyName As String) As Boolean
Dim prop As Variant

    For Each prop In item.UserProperties
        If LCase(prop.Name) = LCase(strPropertyName) Then
            hasProp = True
            Exit For
        End If
    Next
End Function

Open in new window

0
 
MedquestAuthor Commented:
no, I just used the same script you posted by copying and pasting.
was I supposed to delete something from before using it?
0
 
Chris BottomleyCommented:
Not sure, you should one code module with the following, (delete any other code in the module):

Chris
Sub addUSerProp()
Dim calItem As AppointmentItem

    Set calItem = Application.ActiveInspector.CurrentItem.Copy
    If Not hasProp(calItem, "CopyRecord") Then _
        calItem.UserProperties.Add "CopyRecord", olYesNo
    calItem.UserProperties("CopyRecord").Value = True
    calItem.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    MsgBox calItem.UserProperties("CopyRecord") = True
    
End Sub

Function hasProp(item As Object, strPropertyName As String) As Boolean
Dim prop As Variant

    For Each prop In item.UserProperties
        If LCase(prop.Name) = LCase(strPropertyName) Then
            hasProp = True
            Exit For
        End If
    Next
End Function

Open in new window

0
 
MedquestAuthor Commented:
I see what you mean. ok I just did you got those an error message so I clicked on debug.
 

Error3.jpg
0
 
Chris BottomleyCommented:
Ah well that variant also works in 2007 as did the previous one so it must be something about 2010 perhaps to do with the inspector security, but unless we get a positive it isn't worth the effort of experimenting with changing the primary function of copying items.

I'll try to think of alternatives ... tomorrow, i'm outta here now.

Chris
0
 
Chris BottomleyCommented:
Would it be ok to add some specific data into the body of the appointments ... something along the lines of <<autocopy:True>> for example

Chris
0
 
MedquestAuthor Commented:
is this only for testing or is it a requirement for the actual data? the reason I am asking is that I wil have no control over what users store on their calendars in outlook or sharepoint.
 
 
0
 
Chris BottomleyCommented:
IT's for real use as to prevent infinite loops we need a way to append a 'flag' to indicate an item does not need processing and since userproperties seemed to be disabled by your IT I have looked at the appointment properties and the first thought was the body since although we cannot say what is there the addition of a distinct token ought not affect what they do ... and if they delete it later then it is of no matter since it is only needed at the instant the appointment is copied over between folders.

Chris
0
 
MedquestAuthor Commented:
Chris,
I am the IT guy here and I don't think I disabled anything, so I am not sure what's going on. I am starting to even think about any application out there that might do this for me, but I can't find anything on the internet.
I am not saying that I am giving up or anything, but it's just a side thought.
0
 
Chris BottomleyCommented:
>>> I can't find anything on the internet.
Makes me feel a clever so and so ;o)

If you haven't disabled anything we can:

a. try the userproperties approach
b. try the body edit ... but as soon as the 'alternate' copy kicks off use the existence of the flag to stop the copy and delete it as well so it has no real impact on users?

Chris
0
 
MedquestAuthor Commented:
Chris,
I know you're helping me here, but is it possible that you create a test PST file in your outlook, and then trying the tests right there?
this should save some time between the time you post the test and the time I perform the test, and then the time I respond back with the reslut.
is that ok?
0
 
Chris BottomleyCommented:
I have done the tests already hence I know they work for my install ... the ealrier requests for you to try were t make sure they would work for you ... before making specific changes to the solution.

As a volunteer it is not my desire to make multiple attempts at solutions without some confidence that an approach will work hence the tests being requested of you and/or requests for a chosen approach.

Hopefully you now better understand the reason for the requests hence at the moment there are two possible approaches:

a. try the userproperties approach, (in case your test was invalid for some reason)
b. try the body edit ... but as soon as the 'alternate' copy kicks off use the existence of the flag to stop the copy and delete it as well so it has no real impact on users?

Chris
0
 
MedquestAuthor Commented:
I seem to have irritated you with my previous post, and for that I apologize.
ok can we pick from where we left?
how about we try with method A and see if we can get it work before moving on to B.
where do I start?
 
Thanks
0
 
Chris BottomleyCommented:
Sorry I wasn't clear.  We have already implemented a test on your system so option A has the least chance of success.

I suggest we roll with option B which ought to work and can be made transparent to the user(s) IMHO.

If that is agreed then there is nothing you need to do ... I think until I have implemented some code for the method.

Chris
0
 
MedquestAuthor Commented:
oh I got it. so you method B is the way to go but you're still working on the final code for it.
 
right?
 
Thanks
 
0
 
Chris BottomleyCommented:
I will now!

Chris
0
 
Chris BottomleyCommented:
I.m having some trouble creating a test so can you advise:

With the code in http:#33464986 for just 1 folder, does it copy the item to the alternate folder ok.

NOTE*******
Only do this for one folder as otherwise you will end up with a loop copying between the folders.

Chris
0
 
MedquestAuthor Commented:
Chris,
 
the goal here is as follows:
 
Folder1
 
Folder2
 
when an item is created / copied to Folder1, a copy of that item is copied to Folder2
when an item is created / copied to Folder2, a copy of that item is copied to Folder1
 
does this make sense?
0
 
Chris BottomleyCommented:
I understan the requoirement and can implement as long as it works in one direction only.  i'm not getting it to work but I don't have external access so i'm hoping it's just a problem for me.

What I need in order to pursue the solution is the knowledge that with the code supplied at the start http:#33464843 it will work one way and if it does then I will append the checks and balances to prevent it looping infinitely.

Chris
0
 
MedquestAuthor Commented:
I am ready to test myself or provided whatever additional information you might need to make this happen.
 
0
 
Chris BottomleyCommented:
Just the knowledge that it copies something to the sharepoint folder without any errors will be enough for me to proceed.

Let me know how it goes.

Chris
0
 
MedquestAuthor Commented:
have you tested it on your side yet
0
 
Chris BottomleyCommented:
No, like I said i'm not able to do a thorough test.

Chris
0
 
MedquestAuthor Commented:
ok so I am ready to test it now, but with how many posts we have above, I am not sure which code to test or what steps to do to perform the test.
 
can you please copy the code again and tell me what steps I need to do?
 
Thanks
 
0
 
Chris BottomleyCommented:
0
 
MedquestAuthor Commented:
I selected the calendar under sharepoint, and then I hit Alt+F11, and then removed all the text there and pasted the one I copied from http:#33464843 and saved it.
 
I copied a calendar item to that calendar, but it didn't copy it to the other one.
0
 
Chris BottomleyCommented:
Apologies, the code needs to be in thisoutlooksession if it wasn't put there and after doing restart outlook.

The original code there was to detect items dropped into the main calendar and copy them to the sharepoint calendar rather than the other way around.

I have added a check below to try and prevent any recurrence as i'm feeling a little paranoid about it!

Basically for any outlook session it will copy 1 item only.  Use this in thisoutlook session instead of the earlier code.

Chris
Private WithEvents olkCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object
Static bol As Boolean

    If Not bol Then
        Set itmCopy = itm.Copy
        itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
        bol = True
    End If

End Sub

Open in new window

0
 
MedquestAuthor Commented:
I copied the above code, went to outlook, selected the caldendar in sharepoint list, hit alt+f11, removed all the code there and pasted the one I copied, closed outlook and save the project.
I opened outlook again, and then copied calendar items the calendar in sharepint list, and then checked the one in my mailbox and didn't see anything copied.
 
did I do anything wrong?
0
 
Chris BottomleyCommented:
The code needs to be in thisoutlooksession, (elected the caldendar in sharepoint list, hit alt+f11, removed all the code there - you don't say if 'there' iis thisOutlookSession)

The original code there was to detect items dropped into the main calendar and copy them to the sharepoint calendar rather than the other way around, (copied calendar items the calendar in sharepint list).

Chris
0
 
MedquestAuthor Commented:
I am not sure where to look for thisOutlookSession) but as of now I am not seeing it.
0
 
Chris BottomleyCommented:
In the project, expand "Microsoft Office Outlook Objects" and thiOutlookSession is in there.

Chris
0
 
MedquestAuthor Commented:
I just did, closed outlook, saved the project, and then when I opened outlook I got the error message in the attached image.
error.jpg
0
 
Chris BottomleyCommented:
That code is in Module 1 i.e. a normal code module.  Note the earlier comment:

Delete it fom that module and place it in thisOutlookSession

"In the project, expand "Microsoft Office Outlook Objects" and thiOutlookSession is in there"

Chris
0
 
MedquestAuthor Commented:
ok so I did that and I now I am not getting any error message.
 
what should happen at this point?
0
 
Chris BottomleyCommented:
When you drop an item in your normal calendar does it copy to the sharepoint folder ... restart outlook before you test it.

Chris
0
 
MedquestAuthor Commented:
looks like we're alomost there. when I created an appointment in my normal calendar I got an error and I clicked on debug so that you can see what's it about.
Error.jpg
0
 
Chris BottomleyCommented:
Typo

Set itmCopy = itm.Copy
to
Set itmCopy = item.Copy
0
 
MedquestAuthor Commented:
I am not sure what happened but I already tested the last code and seemed to work. I replied and told you that, but I am not seeing my reply here.
 
I applogize for that.
0
 
Chris BottomleyCommented:
lol, it happens ... in my case I find it's gone into some question of no relevance to me at all.

Chri
0
 
Chris BottomleyCommented:
That being the case I guess I need to put something together with the checks and balances.  If you hear nothing in a couple of days - i've forgaotten so please remind me!

Chris
0
 
Chris BottomleyCommented:
OKay the following is an example for 1 folder copy ... basically does the copy occur still?

It is still limited to a copy from the main folder to the sharepoint folder and if it does then a clone of the code for the reverse path should complete things.

Chris
Private WithEvents olkCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    end if

End Sub

Open in new window

0
 
MedquestAuthor Commented:
since the one they'll be seeing is the one in the mailbox, can we make the copy happen from a calendar folder in the mailbox by the name of SharePointListMBX to the share point list in the PST?
 
the would be the ultimate and end solution :)
0
 
Chris BottomleyCommented:
Confused again.

As I understood the development you want to copy from the outlook folder to a sharepoint folder and for the reverse process to work as well.

The code I posted was for one direction which if(when) it proves viable will be scaled up with the reverse process as well.

How does this end solution relate to that understanding?

Chris
0
 
MedquestAuthor Commented:
that's exactly the same as I said, excepted you had a better wording that I am.
so here's how it should work.
a folder with the name of SharePointListMBX in the mailbox.
a folder with the name of share point list in the PST file, which gets created automatically when you connect to share point site.
the goal is to keep these two folders in sync.
I am hope I didn't confuse you even more :)
0
 
Chris BottomleyCommented:
To retry:

You want bi-directional synchronisation.

We have tested a form of uni directional synch and following that success I posted an enhanced form of that uni directional synch with a request for working confirmation.  Once that was confirmed I was going to add the reverse process at which point you posted your request in http:#33570717.

I will assume that as confirmation of the success therefore ...

Chris
Private WithEvents olkCalendar As Outlook.items
Private WithEvents olkSPCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items
    Set olkSPCalendar = Application.Session.folders("SharePoint Lists").folders("CalendarTestPST").items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    end if

End Sub

Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
    end if

End Sub

Open in new window

0
 
MedquestAuthor Commented:
good morning Chris,
 
I just tried it and got the error message and when I clicked on debug it had a highlighted line as you see in the attached image.

Error.jpg
0
 
Chris BottomleyCommented:
Step through and see where it actually fails

Chris
0
 
MedquestAuthor Commented:
it fails on the same line:
If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
0
 
Chris BottomleyCommented:
modifed to check type ... what happens now?

Chris
Private WithEvents olkCalendar As Outlook.items
Private WithEvents olkSPCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items
    Set olkSPCalendar = Application.Session.folders("SharePoint Lists").folders("CalendarTestPST").items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

if activeinspector.CurrentItem.class <> olappointment or activeinspector.CurrentItem.meetingstatus <> olnonmeeting then stop
    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    end if

End Sub

Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

if activeinspector.CurrentItem.class <> olappointment or activeinspector.CurrentItem.meetingstatus <> olnonmeeting then stop
    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
    end if

End Sub
 

Open in new window

0
 
MedquestAuthor Commented:
I got a different error this time.
Error.jpg
0
 
Chris BottomleyCommented:
How do you mean error ... does it pass to the stop command?

If so put the cursor over:
activeinspector.CurrentItem.class
then
activeinspector.CurrentItem.meetingstatus

What do they say?

Chris
0
 
MedquestAuthor Commented:
I am not sure what's going on but now it's working.
 
I created item in the default calendar and it was copied to the other one instantly.
0
 
MedquestAuthor Commented:
just wanted you to know that the new script would work the first time after I open outlook, but then it fails. it's not throuing an error or anything but it's just not copying the items.
 
Thanks
 
0
 
Chris BottomleyCommented:
Can you set restart outlook so that it will process the action.  Now set a break point in the subs - I have added a stop command to both to do this.

Now when you drop an item, the sub will trigger and if you can step through the code letting me know the path it follows ... odds are there is an error occuring to throw the startup settings ... regardless of the lack of a reported error.

Chris
Private WithEvents olkCalendar As Outlook.items
Private WithEvents olkSPCalendar As Outlook.items

Private Sub Application_Startup()

    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items
    Set olkSPCalendar = Application.Session.folders("SharePoint Lists").folders("CalendarTestPST").items

End Sub


Sub olkCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

stop
if activeinspector.CurrentItem.class <> olappointment or activeinspector.CurrentItem.meetingstatus <> olnonmeeting then stop
    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.folders("SharePoint Lists").folders("CalendarTestPST")
    end if

End Sub

Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
dim itmCopy as object

stop
if activeinspector.CurrentItem.class <> olappointment or activeinspector.CurrentItem.meetingstatus <> olnonmeeting then stop
    if instr(1, item.body, "<<AutoCopy>>", vbTextCompare)>0 then
        item.body = replace(item.body, "<<AutoCopy>>", "", 1,, vbTextCompare)
        item.save
        exit sub
    else
        Set itmCopy = itm.Copy
        itmcopy.body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
    end if

End Sub

Open in new window

0
 
MedquestAuthor Commented:
I have dropped the ball on this one and for that I am sorry.
 
can we pick from where we left off?
0
 
Chris BottomleyCommented:
Please do
0
 
MedquestAuthor Commented:
so this is the latest one I've been using, and it keeps poping up with debug windows everytime I accept an appointment:
===================================================================

Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items
Private Sub Application_Startup()
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items
End Sub

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object
If ActiveInspector.CurrentItem.Class <> olAppointment Or ActiveInspector.CurrentItem.MeetingStatus <> olNonMeeting Then Stop
    If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
        Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
        Item.Save
        Exit Sub
    Else
        Set itmCopy = itm.Copy
        itmCopy.Body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
    End If
End Sub
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object
If ActiveInspector.CurrentItem.Class <> olAppointment Or ActiveInspector.CurrentItem.MeetingStatus <> olNonMeeting Then Stop
    If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
        Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
        Item.Save
        Exit Sub
    Else
        Set itmCopy = itm.Copy
        itmCopy.Body = "<<AutoCopy>>"
        itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
    End If
End Sub
 
=================================================================
I'll see if I can have one of the guys here send me a meeting reqeust and see if I get the same error and if I so, I'll send you a copy  of the error.
 
Thanks
 
0
 
MedquestAuthor Commented:
here it is.
VBA-Error.jpg
0
 
Chris BottomleyCommented:
Try changing:

If ActiveInspector.CurrentItem.Class <> olAppointment Or ActiveInspector.CurrentItem.MeetingStatus <> olNonMeeting Then Stop
 
to

If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
 
Chris
0
 
MedquestAuthor Commented:
I tried this one so now I am not getting that error message anymore, but I am not seeing it copying the items to the other calendar.
0
 
MedquestAuthor Commented:
I take this back, I just got another error.
VBA-Error.jpg
0
 
MedquestAuthor Commented:
here's the latest error I've been getting.
 
I went over the script and changed any itm to item thinking it might be the problem, but that didn't help.

VBA-Error.jpg
0
 
Chris BottomleyCommented:
Twoi references to:
       Set itmCopy = itm.Copy
need to be
       Set itmCopy = item.Copy

Chris
Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items 
Private Sub Application_Startup() 
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
   Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items 
End Sub 

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If ActiveInspector.CurrentItem.Class <> olAppointment Or ActiveInspector.CurrentItem.MeetingStatus <> olNonMeeting Then Stop
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
   End If 
End Sub 
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If ActiveInspector.CurrentItem.Class <> olAppointment Or ActiveInspector.CurrentItem.MeetingStatus <> olNonMeeting Then Stop
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
   End If 
End Sub

Open in new window

0
 
MedquestAuthor Commented:
I copied the entire script from your last and post and then tried and got an error.
VBA-Error.jpg
0
 
Chris BottomleyCommented:
Needed to re-assert the earlier 'change'

Chris
Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items 
Private Sub Application_Startup() 
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
   Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items 
End Sub 

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
   End If 
End Sub 
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
   End If 
End Sub

Open in new window

0
 
MedquestAuthor Commented:
sorry for yesterday. we had a fire drill and I have to leav the building.
 
so I this is the error I am getting today.
 
Thanks Chris

VBA-Error.jpg
0
 
Chris BottomleyCommented:
i CHANGED THAT BACK TO THE FIX IN THE MOST RECENT POST!

cHRIS
0
 
Chris BottomleyCommented:
capslock! - sorry about that
0
 
MedquestAuthor Commented:
just tried it and got an error messag
VBA-Error.jpg
0
 
Chris BottomleyCommented:
WHat error message?
0
 
MedquestAuthor Commented:
the one in the screen shot.
what I also noticed is that even though it's throughing that error, it still moved the new item to the other calendar.
0
 
Chris BottomleyCommented:
The code is breaking on that line ... if it was an error then there would be a message type box presenting the error.

Try closing outlook and re-opening anew.

Chris
0
 
MedquestAuthor Commented:
please see this screenshot for the exact error
VBA-Error.jpg
0
 
Chris BottomleyCommented:
In the VB Editor, try debug | clear all breakpoints and see what happens.

Chris
0
 
MedquestAuthor Commented:
what breakpoints are we talking about?
0
 
Chris BottomleyCommented:
I don't know ... your problem appears to be the editor is breaking code execution.  IF there was an error it wouldn't progress past the line and there would be a specific message box referring to the error.

Hence I am wracking my brain to try and think what would cause it to break.  At this point for a given run time selecting all break points to be cleared will be a step one way or the other.

CHris
0
 
Chris BottomleyCommented:
Don't know if we have already tried this but recheck anyway:

IN teh Visual BAsic Editor, (alt + F11 from the outlook app)

Select tools | References.
LOok for any entries with missing against them and if found uncheck them then retry.

Chris
0
 
MedquestAuthor Commented:
only 4 options selected as you can see in the attached image.

VBA-References.png
0
 
Chris BottomleyCommented:
And it still breaks?  .. have you tried a complte reboot?

Chris
0
 
MedquestAuthor Commented:
oh many times. I use my laptop at home and at work, so I have to shut it down to bring it to the office and then again to take it home.
 
what's interesting right now is that when I am testing it and create an item and see the debug message; it still moves the item I created to the other one.
0
 
Chris BottomleyCommented:
WHat happens if you out either of the folder moves:

'Private WithEvents olkCalendar As Outlook.items
Private WithEvents olkSPCalendar As Outlook.items

Private Sub Application_Startup()

'    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).items
    Set olkSPCalendar = Application.Session.folders("SharePoint Lists").folders("CalendarTestPST").items

End Sub

and then vice versa
0
 
MedquestAuthor Commented:
I am not sure I understand what changes I need to make.
can you post the script with the first change, and then again with the second change?
 
Thanks Chris.
0
 
Chris BottomleyCommented:
One
'Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items 
Private Sub Application_Startup() 
'    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
   Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items 
End Sub 

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
   End If 
End Sub 
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
   End If 
End Sub

Open in new window

0
 
Chris BottomleyCommented:
Two
Private WithEvents olkCalendar As Outlook.Items
'Private WithEvents olkSPCalendar As Outlook.Items 
Private Sub Application_Startup() 
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
'   Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items 
End Sub 

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
   End If 
End Sub 
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
   End If 
End Sub

Open in new window

0
 
MedquestAuthor Commented:
the first one didn't return any errors and didn't copy anything when testing, the second one returned the error you see in the attached image.
VBA-Error.jpg
0
 
Chris BottomleyCommented:
Did you try the copy the 'other' way around for the first example?  i.e. one was from main calendar to remote calendar and the other is the other way around

Chris
0
 
MedquestAuthor Commented:
I just did and got the attached error
VBA-Error.jpg
0
 
Chris BottomleyCommented:
Now try a dummy line to see if there is something in the command or just generic VBA

Chris
Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items 
Private Sub Application_Startup() 
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
   Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items 
End Sub 

Sub olkCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
debug.print now()
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
   End If 
End Sub 
Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
Dim itmCopy As Object 
debug.print now()
If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub
   If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
       Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
       Item.Save
       Exit Sub
   Else
       Set itmCopy = item.Copy
       itmCopy.Body = "<<AutoCopy>>"
       itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
   End If 
End Sub

Open in new window

0
 
MedquestAuthor Commented:
I just tested it and the result is attached.
VBA-Error.jpg
0
 
MedquestAuthor Commented:
Chris,
 
I guess am calling it a quit, but I am not going to close the question and instead I am going to accept any of your answers since you've been trying to help me this long.
 
Thanks for trying.
0
 
Chris BottomleyCommented:
bear with me whilst I refresh my memory of where this is ... I am concerned that I have not responded to a post from you.

Chris
0
 
MedquestAuthor Commented:
I don't think this is the case, but by looking at how long this thread is, I am thinking this may really not work unless you think otherwise.
 
again thanks a lot for your help with this.
0
 
Chris BottomleyCommented:
Try taking all the code in the module and pasting it into a text file.

Now delete all the code in the module and then paste it back from the text file ... just in case there are any stray control codes anywhere in the module itself.

Chris
0
 
Chris BottomleyCommented:
I have also had a go at inviting other experts to assist with why the code keps breaking so hopefully someone will help us out on that concern.

Chris
0
 
mvidasCommented:
Medquest,

Your recent screenshots show where the error is, but not what the error is. Is there any sort of pop-up window stating the error description (like there was in http:#33468047 in the first image), and if so what is the error text?

Matt
0
 
Chris BottomleyCommented:
MAtt

from my requests ... It's so much there is a fault in the code it's just that the VBE breaks on the line:

If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then exit sub

every time the code executes - no breakpoints set as far  as I have been able to ascertain but Medquest,
 can answer more definitively of course.

Chris
0
 
David LeeCommented:
Chris,

I believe the problem is that the code is going into an infinite loop.  When it copies the newly added appointment that creates an ItemAdd event on that calendar.  The new item triggers the ItemAdd event again which copies the new addition creating a new ItemAdd event and so on ad infinitum.  The solution is to disable event monitoring, copy the item, then re-enable event monitoring.  I've modified the code accordingly and it works fine for me.  
Private WithEvents olkCalendar As Outlook.Items
Private WithEvents olkSPCalendar As Outlook.Items

Private Sub Application_Startup()
    MonitorCalendar
    MonitorSPCalendar
End Sub

Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Dim itmCopy As Object
    Debug.Print Now & vbTab & "Calendar"
    If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then Exit Sub
    If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
        Debug.Print Now & vbTab & "Copy from SPCalendar"
        Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
        Item.Save
        Exit Sub
    Else
        Debug.Print Now & vbTab & "Copy to SPCalendar"
        MonitorCalendar
        Set itmCopy = Item.Copy
        MonitorCalendar
        itmCopy.Body = "<<AutoCopy>>"
        itmCopy.Save
        itmCopy.Move Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST")
    End If
End Sub

Sub olkSPCalendar_ItemAdd(ByVal Item As Object)
    Dim itmCopy As Object
    Debug.Print Now() & vbTab & "SPCalendar"
    If Item.Class <> olAppointment Or Item.MeetingStatus <> olNonMeeting Then Exit Sub
    If InStr(1, Item.Body, "<<AutoCopy>>", vbTextCompare) > 0 Then
        Debug.Print Now & vbTab & "Copy from Calendar"
        Item.Body = Replace(Item.Body, "<<AutoCopy>>", "", 1, , vbTextCompare)
        Item.Save
        Exit Sub
    Else
        Debug.Print Now & vbTab & "Copy to Calendar"
        MonitorSPCalendar
        Set itmCopy = Item.Copy
        MonitorSPCalendar
        itmCopy.Body = "<<AutoCopy>>"
        itmCopy.Save
        itmCopy.Move Application.Session.GetDefaultFolder(olFolderCalendar)
    End If
End Sub

Sub MonitorCalendar()
    If TypeName(olkCalendar) = "Nothing" Then
        Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    Else
        Set olkCalendar = Nothing
    End If
End Sub

Sub MonitorSPCalendar()
    If TypeName(olkSPCalendar) = "Nothing" Then
        Set olkSPCalendar = Application.Session.Folders("SharePoint Lists").Folders("CalendarTestPST").Items
    Else
        Set olkSPCalendar = Nothing
    End If
End Sub

Open in new window

0
 
MedquestAuthor Commented:
that did the trick and it worked beautifully.
 
Thanks a lot guys.
0
 
MedquestAuthor Commented:
excellent.
0
 
David LeeCommented:
Cool.  Glad it worked.  Chris deserves the majority of the credit, not me.  I just helped solve one problem.
0
 
MedquestAuthor Commented:
BlueDevilFan,
 
I am not sure if this is by design or not. ok so when I create an appointment on either one it gets copied to the other one, but when I delete it, it's not getting deleted from the other one.
 
is something something else we need to add for it to update each other everytime there's a change?
0
 
Chris BottomleyCommented:
Cheers David, intersting way to stop the event firing!

Chris
0
 
David LeeCommented:
Deleting is a real problem, one that's not easily handled.  While an event (ItemRemove) is triggered when an item is deleted from a folder the event procedure doesn't know which item was deleted.  It just knows that something has been removed.  There are two ways to handle this, neither of them especially simple or pretty.  First, write code for the ItemRemove event that does an item by item comparison of the target folder to the source folder (i.e. the item was removed from).  For each item in the target folder search the source folder to see if it exists there.  If there's no match, then that's the item that was deleted so delete it here too.  Of course this creates a performance hit that gets more pronounced as the number of items in the folder gets larger.  If there are 1,000 items in each calendar and you delete 5 of them, then the code has to read 1,000 + 999 + 998 + 997 + 996 items.  In otehr words, don't expect it to be fast.  The second solution, writing an explorer wrapper, eliminates this issue but is much more complicated to produce.  An explorer wrapper is a class module that keeps track of each explorer window and each open item.  This allows the code to trap the delete event for an item instead of the folder's ItemRemove event.  This allows you to know exactly which item is being deleted so you can delete the same item from the opposing folder.  You can do this without writing a wrapper, but it will fail if you ever open more than one item at a time, ever switch between open items, or open more than one explorer window.  The problem is that VBA does not have built-in support for an array of objects.  You have to craft your own.  

There are other problems too, including one that you may not have thought of yet.  Outlook items don't have a globally unique identifier so finding an item can be dicey.  For example, assume that you just deleted one instance of an appointment titled "Weekly Project Meeting" and the code now needs to find and delete that same meeting from the other calendar.  How will it find a match?  It can't use the subject alone since there are other appointments with the same title.  Of course you can use a combination of subject and start/end times, but that's not as simple as it could be.  The other issue, the one you may have overlooked, is changes.  The code you have now copies new items, and you've asked about deleting items, but if the goal is to keep the items in sync, then you have to consider changes too.  That means trapping another event and again having to find the matching item and change it too.

The bottom line to this is that coding a process to keep any two folders in sync is NOT a simple task.  It would be really nice if Microsoft would expose the objects that do this without the need to write any code.  The capability is already there as evidenced by the fact that Outlook can sync with the Exchange server and with a Sharepoint folder.  
0
 
MedquestAuthor Commented:
well, you guys went above and beyound the extra mile to help with this issue and sometimes it just gets to the point where we say "it is what it is" and there's nothing we can do about it.
 
thanks to everyone.
0
 
David LeeCommented:
You're welcome.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 66
  • 64
  • 4
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now