Ok I have an excell sheet that I have set up to email out and to add an all day event to an outlook calender. There are two problems I'm having, one is that I can't get it to update the calender unless I already have outlook open. I'm using the following to access outlook

Private Sub GetFolderFromID(Subj, ShipDate)
Dim olfolder As Outlook.MAPIFolder
Dim olapp As New Outlook.Application
Set olapp = CreateObject("Outlook.Application")
Set olfolder = olapp.GetNamespace("Mapi").GetFolderFromID("PublicFolderID")
Set myItem = olfolder.Items.Add(olAppointmentItem)
myItem.Subject = Subj
myItem.AllDayEvent = True
myItem.Start = ShipDate
Set olfolder = Nothing
Set olapp = Nothing
End Sub

this will do exactly what I want when outlook is open, but if outlook wasn't opened before hand it will error out and say that outlook needs to be restarted. How can I open up a copy of outlook right before this executes (the bolded line is the one that can't execute unless outlook is open).

My second question is, is there anyway to change the color of an appointment? I'm adding 2 appointments to this calender and I want one to be blue (label called Travel Required) one to be orange (label called Phone Call). Anybody know of a way to add color to these (anyway would be great, the label method just seemed convinient if I can find a way for it to work).

Any help would be much appreciated.

11 Years
Discussion Span
Last Post by Kegtapper

the problem with this method is that you are trying to set a FolderID based upon (Subj, Shipdate) as integer, index or variable.

If you:

Private Sub Command1_Click() '.....can change to Sub.....
Dim olapp As New Outlook.Application
Dim olfolder As Outlook.MAPIFolder

Set olapp = CreateObject("Outlook.Application")
Set olfolder = olapp.GetNamespace("Mapi").GetDefaultFolder(olFolderCalendar)
Set myItem = olfolder.Items.Add
myItem.Subject = "Another Meeting"
myItem.Location = "Under the Stairwell"
myItem.AllDayEvent = True
myItem.Start = #12/9/2005#
myItem.Body = "Bring Donuts and Jelly Rolls"
Set olfolder = Nothing
Set olapp = Nothing
End Sub

This would pass through. If you named the underlined item to the FolderName rather than using the ID it would find the folder.

One issue with resolving this is that, I am on internet Outlook folder rather than IMAP/Exchange server. So I have no access to ("Public Folders") and give you a complete answer.
On your example: try without New Outlook.Application (that generates a new session instance) and Outlook closed.
You can test, make changes- however remember an Exchange DB is flat, not-relational, so integers are treated as variables and not numbers, so indexing isn't much help.

You can change colors with AppointmentItem values

Hope that helps


Thank you, I'll have to try that, the whole public folder part is the tricky part though, from what I can understand outlook treats public folders really oddly and doesn't seem to like their names too much.

As for the color, do you know what I can change in AppointmentItem? I couldn't find anything listing the members of AppointmentItem. I'd even be happy changing the font color but I haven't really looked into that.


Sorry, I don't have the hierachy of the PublicFolders. Since I hadn't worked with Outlook and VBA in a couple of years, and worked in several other languages since, its no longer on the top of my head. I had designed a LitigationTracking PIM App (for some corporate Lawyers) but can't find the CD. If it shows up I will check the code I already designed.

to change the text on the Calendars the easiest way is VBScript on the BeforeDisplay event.

You'd have to check the VIEWS first [whether 1day/Week/Month] before setting the fonts & colors. That will help determine if a font will fit.

Then Check the Increments (6,15,30,60 etc).


Finally found my old app.

To navigate the Public Folders try this method (excerpts)
'On Error GoTo Err_Form_Load
Set ol = GetObject(, "Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set pubFolder = ns.Folders("Public Folders")
Set allPubFolders = pubFolder.Folders("All Public Folders")
Set lglFolder = allPubFolders.Folders("Named_Folder")
Set lglCalendar = lglFolder.Folders("Named_Calendar")
Set calItem = lglCalendar.Items
' this stuff below checked dates and animated Assistant or Displayed calendar
Set appt = calItem.Find("[Start] >= """ & CritDate & """ and [Start] <= """ & CritEnd & """")
While TypeName(appt) <> "Nothing"
ltClip = Len(appt.Body) - 2
If ltClip > 0 Then
Me.ctlMarquee.Value = "CASENAME: " & appt.Subject & " ---> SUBJECT: " & Left(appt.Body, ltClip) ' Display the Calendar
End If
MsgBox "There are Appointments for " & appt.Subject, vbOKOnly, "Todays Appointments..."
Set appt = calItem.FindNext

Set cUser = ns.CurrentUser
lblUserName.Caption = cUser
lblDate.Caption = FormatDateTime(Date, vbLongDate)

'On Error GoTo Err_Form_Load

'Check the Assistant Checkbox, if Checked then Move the Assistant over and make it visible, if Not Then Hide it.....
If chkUseAsst.Value = True Then
With Assistant
.Move 640, 0
.Visible = True
.Animation = msoAnimationGestureRight
End With
With Assistant
.Visible = False
End With
End If
Exit Sub

'end snippets - use what you need

aka Kegtapper

This topic has been dead for over six months. Start a new discussion instead.
Have something to contribute to this discussion? Please be thoughtful, detailed and courteous, and be sure to adhere to our posting rules.