Outlook Calendar 2007 - Invitation Times

[Outlook Rookie]

Hi,

Is there a vba script that will pop up when a meeting is scheduled at incorrect times say after 6:00pm and before 7:00am?

I am using Windows 7, and Office 2007 as well.

Any assistance is appreciated.

Thank youl

 

[Diane Poremsky]

I don't have one ready to go, but it shouldnt be hard to do. I'll see what i can come up with.

 

[Diane Poremsky]

Try this - http://www.slipstick.com/developer/check-start-end-times-new-appointments/ - it pops up a warning when the times are outside of the selected hours.

 

[Outlook Rookie]

Hi Diane,

Thank you for your quick response. I tried it and it gives me an error message "Compile error: Only valid in object module". It highlights the "WithEvents" in blue. When I try to Run it, it opens up the Macros box for a name creation, etc.

I seem to be doing everything listed in your thread. Since I am a real Rookie , could you please simplify it for me, do I paste the entire script or do I remove the green line 'change the start time...'. I tried with both and neither seem to work. Can you please help?

Thank you.

 

[Forum Admin]

You need to paste it in ThisOutlookSession - if you have other macros in thisoutlooksession, the withevents line needs to be at the top of the page. Application_Startup should be near the top too. Click on Set Ns line and then click Run. Also, you need macro security set to low during testing.

http://www.slipstick.com/developer/how-to-use-outlooks-vba-editor/ has a bit more information and screenshots.

 

[Outlook Rookie]

Hi again,

I have good news and bad news

I think I had to close Outlook to work - and it did! So the vba works great. An appointment scheduled out of the specified times sends a popup alert.

However, if I take an existing message and change the start or end times to a time out of the eligible times, it does not send the alert. The second issue is it is sends a popup for any invitation starting before 8:00. Is this because of the GMT or local times? I am in the PST time zone.

Thank you for all your help.

 

[Diane Poremsky]

The macro only looks for items added, not items changed. I'll have to test it to be sure, but I think you need to add these lines at the top

Public WithEvents OlItems As Outlook.Items

Public Sub Initialize_handler()
Set OlItems = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderCalendar).Items

End Sub

Copy the ItemAdd macro and change the first line to this -

Private Sub OlItems_ItemChange(ByVal Item As Object)

(I'll test it and add it to the webpage.)

The code is time zone insensitive - these lines control the times it checks. It should look ofr appt before 8 AM or that end after 7 PM. Edit the times as needed. If you want to check the start time instead of the end time, change item.end to item.start

If TimeValue(Item.Start) < TimeValue("7:59:00 AM") Or _
TimeValue(Item.End) > TimeValue("7:00:00 PM") Then

 

[Diane Poremsky]

I did some quick tests - copy the application_startup, paste the copy under the current startup marco. Copy the itemadd macro and paste under the current itemadd.

Replace the first line (sub name line) of application_startup with

Public Sub Initialize_handler()

and replace the itemadd first line with

Private Sub Items_ItemAdd(ByVal Item As Object)

It's a little cleaner than using two different variable names (but that works too).

 

[Outlook Rookie]

Hi Diane,

I did the edits as suggested and it still does not work for a revised appointment. To make it easy please look at the attached file.

I tried to upload a Word document with the script and I received an error about the file not being compatible. When I made a .pdf it exceeded the byte space, so here is the script that I am using.

New Script

Private WithEvents Items As Outlook.Items

Public Sub Initialize_handler()

Dim Ns As Outlook.NameSpace

Set Ns = Application.GetNamespace("MAPI")

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error Resume Next

' change the start and end times as needed

If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _

TimeValue(Item.End) > TimeValue("4:59:00 PM") Then

strMsg = "This appointment is scheduled to start at " & _

vbCrLf & TimeValue(Item.Start) & " and end at " & _

TimeValue(Item.End) & vbCrLf & _

"Do you still want to schedule it?"

intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")

' If you say no, the opens for you to change the times or delete it.

If intRes = vbNo Then
Item.Display

End If

End If

End Sub

To make it easy for me, could you please send me a single correct script.

Thanks,

Outlook Rookie for sure!

 

[Outlook Rookie]

Hello again,

Can you pls check the script to offer the prompt for revised bookings as well.

Thank you.

 

[Outlook Rookie]

Hi.

Could someone please update the script to include the prompt for existing bookings as well. Please, please, please?

Thank you.

 

[Diane Poremsky]

I did some quick tests - copy the application_startup, paste the copy under the current startup marco. Copy the itemadd macro and paste under the current itemadd.




Replace the first line (sub name line) of application_startup with




Public Sub Initialize_handler()


and replace the itemadd first line with




Private Sub Items_ItemAdd(ByVal Item As Object)




It's a little cleaner than using two different variable names (but that works too).

There is a typo in this (sorry about that) - it should be




Private Sub Items_ItemChange(ByVal Item As Object)




You need both the original macros for new items and also a copy for the item change. This should work -




Public Sub Initialize_handler()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
End Sub




Private Sub Items_ItemChange(ByVal Item As Object)
On Error Resume Next
' change the start and end times as needed
If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _
TimeValue(Item.End) > TimeValue("4:59:00 PM") Then
strMsg = "This appointment is scheduled to start at " & _
vbCrLf & TimeValue(Item.Start) & " and end at " & _
TimeValue(Item.End) & vbCrLf & _
"Do you still want to schedule it?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")
' If you say no, the opens for you to change the times or delete it.
If intRes = vbNo Then
Item.Display
End If
End If
End Sub

 

[Outlook Rookie]

I tried the new script and it does not work at all. Even new bookings can be scheduled without the popup alert. This time I logged off completely and it still did not work.

 

[Diane Poremsky]

What is your macro security setting? Did you click in the application Startup macro and click run to kick start it? Do you get any error messages?

If you get error messages - you need to DIM the two variables -

After On Error Resume Next, add
Dim strMsg As String
Dim intRes

 

[Outlook Rookie]

Thank you for your support in still trying to help me. The macro security settings are set to “Warning for all macros” by default and this cannot be changed. There are no error messages received with any scripts including the latest script. I found the original script and tested it again and it works fine ONLY for new invitations and not for revised invitations. So here below is what I currently have which works for new invitations, which is followed by the latest script which does not work for new or existing invitations. Can you please see where the fix is needed and send me the corrected script. Thank you again. Script that works for NEW invitations

Private WithEvents Items As Outlook.Items

Public Sub Initialize_handler()

Dim Ns As Outlook.NameSpace

Set Ns = Application.GetNamespace("MAPI")

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error Resume Next

' change the start and end times as needed

If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _

TimeValue(Item.End) > TimeValue("4:59:00 PM") Then

strMsg = "This appointment is scheduled to start at " & _

vbCrLf & TimeValue(Item.Start) & " and end at " & _

TimeValue(Item.End) & vbCrLf & _

"Do you still want to schedule it?"

intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")

' If you say no, the opens for you to change the times or delete it.

If intRes = vbNo Then
Item.Display

End If

End If

End Sub

Script that does not work for new or existing invitations

Public Sub Initialize_handler()

Dim Ns As Outlook.NameSpace

Set Ns = Application.GetNamespace("MAPI")

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items

End Sub

Private Sub Items_ItemChange(ByVal Item As Object)

On Error Resume Next

' change the start and end times as needed

If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _

TimeValue(Item.End) > TimeValue("4:59:00 PM") Then

strMsg = "This appointment is scheduled to start at " & _

vbCrLf & TimeValue(Item.Start) & " and end at " & _

TimeValue(Item.End) & vbCrLf & _

"Do you still want to schedule it?"

intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")

' If you say no, the opens for you to change the times or delete it.

If intRes = vbNo Then

Item.Display

End If

End If

End Sub

 

[Diane Poremsky]

The first

Public Sub Initialize_handler()

should be Private Sub Application_Startup()

Although if item add works with initialize handler, both should.

This works for changed items here - you need to add the 2 Dim's to avoid errors. If you aren't getting an object error, then the macro isn't even running - try clicking in the initialize hander macro and clicking Run.

Public Sub Initialize_handler()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
End Sub
Private Sub Items_ItemChange(ByVal Item As Object)
On Error Resume Next

Dim strMsg As String
Dim intRes
' change the start and end times as needed
If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _
TimeValue(Item.End) > TimeValue("4:59:00 PM") Then
strMsg = "This appointment is scheduled to start at " & _
vbCrLf & TimeValue(Item.Start) & " and end at " & _
TimeValue(Item.End) & vbCrLf & _
"Do you still want to schedule it?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")
' If you say no, the opens for you to change the times or delete it.
If intRes = vbNo Then
Item.Display
End If
End If
End Sub

 

[Outlook Rookie]

Hi

I tried the last script with the changes and it does not work either for new or for existing invites. I have clicked the Run as well as Debug and do not get an error. However, I pasted the original script again and it worked fine ONLY for new messages. I also have other macros that are working well.

Thank you for you help.

Have a good Christmas and Holiday Season. Perhaps Santa will work his magic and make this macro work. That would be the best Christmas present ever!

 

[Outlook Rookie]

Happy New Year to all at this Forum!

Do you have an update?

Thank you.

 

[Diane Poremsky]

This works with appointments and edited appointments as well as meeting and meeting updates.

 
 

 
 
Private WithEvents Items As Outlook.Items
 
 
 
Private Sub Application_Startup()
 Dim Ns As Outlook.NameSpace
 Set Ns = Application.GetNamespace("MAPI")
 Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
 
 
End Sub
 
 

 
 

Public Sub Initialize_handler()
Dim Ns As Outlook.NameSpace 
Set Ns = Application.GetNamespace("MAPI") 
Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items 
End Sub
 
 


 
 
Private Sub Items_ItemAdd(ByVal Item As Object)
 On Error Resume Next

 
 
' change the start and end times as needed
 
 
If TimeValue(Item.Start) < TimeValue("7:59:00 AM") Or _
   TimeValue(Item.End) > TimeValue("7:00:00 PM") Then
    
   strMsg = "This appointment is scheduled to start at " & _
   vbCrLf & TimeValue(Item.Start) & " and end at " & _
   TimeValue(Item.End) & vbCrLf & _
   "Do you still want to schedule it?"
   intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours")
    
 
 
' If you say no, the opens for you to change the times or delete it.
   If intRes = vbNo Then
     Item.Display
   End If
    
 
 
End If
 
 
 
End Sub
 
 

 
 

Private Sub Items_ItemChange(ByVal Item As Object)
On Error Resume Next
' change the start and end times as needed 
If TimeValue(Item.Start) < TimeValue("6:59:00 AM") Or _ 
TimeValue(Item.End) > TimeValue("4:59:00 PM") Then
strMsg = "This appointment is scheduled to start at " & _ 
vbCrLf & TimeValue(Item.Start) & " and end at " & _ 
TimeValue(Item.End) & vbCrLf & _ 
"Do you still want to schedule it?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Confirm Appointment Hours") 
' If you say no, the opens for you to change the times or delete it. 
If intRes = vbNo Then
Item.Display 
End If
End If
End Sub

 

[Outlook Rookie]

Hi Diane,

This works great - for new and existing invitations. Thank you so much for your patience and support.

I am really very, very appreciative.

Outlook Rookie