ISO: Excel macro that will grab Outlooks Calendar events...

JDM-LTCS

New Member
Joined
Sep 7, 2006
Messages
40
based on their "labels".

I have one that uses the categories but my higher-up's feel that asking our employees to select both a label and a color (2 clicks) is just too much.

Of course my suggestion of "make labels optional and categories mandatory" didn't solve the problem. :unsure:

If there's a simple way of just re-working the macro to pull the field (label) as opposed to the field (category), I'm not finding it.

Anyways, thanks in advance.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

JDM-LTCS

New Member
Joined
Sep 7, 2006
Messages
40
I rooted through the website, found one that looked close only to have it no longer be a valid link.

So I'll root through there some more.

Here's the current code I have which pulls the data out of Outlook's calendar:

Sub Get_Outlook_Appts()
Dim oNameSpace As Outlook.NameSpace
Dim oApp As Outlook.Application
Dim oAppt As Outlook.AppointmentItem
Dim oRecurPattern As Outlook.RecurrencePattern
Dim oCalendar As Outlook.MAPIFolder
Dim oItems As Items
Dim sFilter As String

Dim dCategories As String
Dim dSubject As String
Dim dStart As Date
Dim dEnd As Date
Dim row As Integer
Dim Week_End As Date
Dim Week_Begin As Date
Dim ws_data As Worksheet

Week_End = Worksheets("Control").Range("Week_Ending").Value
Week_Begin = Week_End - 7
Set ws_data = Worksheets("Data")

Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oCalendar = oNameSpace.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items

oItems.Sort "[Start]"
oItems.IncludeRecurrences = True ' ensure recurring appts are included
sFilter = "[Start] >= '" & Format(Week_Begin + 1, "ddddd h:nn AMPM") & "' AND [Start] < '" & Format(Week_End + 1, "ddddd h:nn AMPM") & "'"
Set oAppt = oItems.Find(sFilter)

' Delete previous entries for same week
row = 1
While Not IsEmpty(ws_data.Cells(row, 1))
If ws_data.Cells(row, 1).Value = Week_End Then
ws_data.Rows(row).Delete
Else
row = row + 1
End If
Wend

While Not oAppt Is Nothing
If ((oAppt.End - oAppt.Start) < 1) Then ' exclude 24 hour or longer appts
With oAppt
ws_data.Cells(row, 1).Value = Week_End
ws_data.Cells(row, 2).Value = Week_End - Day(Week_End) + 1
ws_data.Cells(row, 3).Value = .Categories
ws_data.Cells(row, 4).Value = .Subject
ws_data.Cells(row, 5).Value = .Start
ws_data.Cells(row, 6).Value = .End
ws_data.Cells(row, 7).Value = 24 * (.End - .Start)
End With
row = row + 1
End If

Set oAppt = oItems.FindNext
Wend

'Release the object variables
Set oAppt = Nothing
Set oItems = Nothing
Set oCalendar = Nothing
Set oNameSpcae = Nothing
Set oApp = Nothing
Set oOutlook = Nothing
End Sub
 

JDM-LTCS

New Member
Joined
Sep 7, 2006
Messages
40

ADVERTISEMENT

defintion of "labels"

In MS Outlook, you can color-code each appointment based on 10 colors. These are called "labels". You can edit each label name but you cannot change the color.

My higher-up's want our staff to use the color-coding so they can visually see where they're spending their time and on what. But the macro I have to export their appointments and sort them is based on the field "categories", not for "labels". And I can't figure out how to do this.


Make sense?
 

sbendbuckeye

Active Member
Joined
Nov 26, 2003
Messages
440
Hello,

Check out this link: http://www.outlookcode.com/codedetail.aspx?id=139

This code will get you close - sorry I don't have time to play with it right now. It is setting the value but it shouldn't be too difficult to get it to read the value instead. You will need a reference to Microsoft CDO 1.1. Good Luck!
Code:
    sFilter = "[Start] >= '" & Format(Week_Begin + 1, "ddddd h:nn AMPM") & "' AND [Start] < '" & Format(Week_End + 1, "ddddd h:nn AMPM") & "'"
    Set oAppt = oItems.Find(sFilter)

    ' Added the following to your code to change the color
    Call SetApptColorLabel(oAppt, 4)
Code:
Sub SetApptColorLabel(objAppt As Outlook.AppointmentItem, _
                      intColor As Integer)
    ' requires reference to CDO 1.21 Library
    ' adapted from sample code by Randy Byrne
    ' intColor corresponds to the ordinal value of the color label
        '1=Important, 2=Business, etc.
    Const CdoPropSetID1 = "0220060000000000C000000000000046"
    Const CdoAppt_Colors = "0x8214"
    Dim objCDO As MAPI.Session
    Dim objMsg As MAPI.Message
    Dim colFields As MAPI.Fields
    Dim objField As MAPI.Field
    Dim strMsg As String
    Dim intAns As Integer
    On Error Resume Next
    
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    If Not objAppt.EntryID = "" Then
        Set objMsg = objCDO.GetMessage(objAppt.EntryID, _
                                   objAppt.Parent.StoreID)
        Set colFields = objMsg.Fields
        Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)
        If objField Is Nothing Then
            Err.Clear
            Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)
        Else
            objField.Value = intColor
        End If
        objMsg.Update True, True
    Else
        strMsg = "You must save the appointment before you add a color label. " & _
                 "Do you want to save the appointment now?"
        intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment Color Label")
        If intAns = vbYes Then
            Call SetApptColorLabel(objAppt, intColor)
        Else
            Exit Sub
        End If
    End If
                      
    Set objAppt = Nothing
    Set objMsg = Nothing
    Set colFields = Nothing
    Set objField = Nothing
    objCDO.Logoff
    Set objCDO = Nothing
End Sub
 

sbendbuckeye

Active Member
Joined
Nov 26, 2003
Messages
440
Retrieving Appointment Label Color from Outlook

Hello,

Here is a function that will return the label color for you. It seems a little sluggish, presumably because it logs on and off CDO every time. Perhaps it would speed up if you logged onto the CDO object once and passed it into the function.
Rich (BB code):
Function GetApptColorLabel(objAppt As Outlook.AppointmentItem) As Integer
    On Error Resume Next
    ' Requires reference to CDO 1.21 Library
    ' Adapted from sample code by Randy Byrne posted on www.OutlookCode.com
    ' link: http://www.outlookcode.com/codedetail.aspx?id=139
    
    ' intColor corresponds to the ordinal value of the color label
        '1=Important, 2=Business, etc.
    Const CdoPropSetID1 = "0220060000000000C000000000000046"
    Const CdoAppt_Colors = "0x8214"
    Dim objCDO As MAPI.Session
    Dim objField As MAPI.Field
    
    ' Create implicit CDO object
    With CreateObject("MAPI.Session")
        .Logon "", "", False, False
        If Len(Trim$(objAppt.EntryID)) > 0 Then
            With .GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)
                Set objField = .Fields.Item(CdoAppt_Colors, CdoPropSetID1)
                If objField Is Nothing Then
                    Err.Clear
                    MsgBox "Error processing appt " & objAppt.Subject, vbCritical, "Appt Label Error"
                    GetApptColorLabel = 0
                Else
                    GetApptColorLabel = objField.Value
                End If
            End With
        End If
        .Logoff
    End With
    Set objField = Nothing
    On Error GoTo 0
End Function 'GetApptColorLabel
As an aside, the following may speed up your loop also. It is quicker to write the range from an array than to set up each cell separately.
Rich (BB code):
While Not oAppt Is Nothing
    ' Exclude 24 hour or longer appts
    If ((oAppt.End - oAppt.Start) < 1) Then 
        With oAppt
            Dim varData As Variant
            ReDim varData(7)
            varData(0) = Week_End
            varData(1) = Week_End - Day(Week_End) + 1
            varData(2) = .Categories
            varData(3) = .Subject
            varData(4) = .Start
            varData(5) = .End
            varData(6) = 24 * (.End - .Start)
            varData(7) = GetApptColorLabel(oAppt)

            '  Transpose the array so it is ones based.
            varData = Application.WorksheetFunction.Transpose(varData)
            varData = Application.WorksheetFunction.Transpose(varData)

            ' Copy the array to the specified range.
            With ws_data
                .Range(.Cells(row, "A"), .Cells(row, "H")).Value = varData
            End With
                
'           ws_data.Cells(row, 1).Value = Week_End
'           ws_data.Cells(row, 2).Value = Week_End - Day(Week_End) + 1
'           ws_data.Cells(row, 3).Value = .Categories
'           ws_data.Cells(row, 4).Value = .Subject
'           ws_data.Cells(row, 5).Value = .Start
'           ws_data.Cells(row, 6).Value = .End
'           ws_data.Cells(row, 7).Value = 24 * (.End - .Start)
'           ws_data.Cells(row, 8).Value = GetApptColorLabel(oAppt)
        End With
        Application.StatusBar = _
            "Processing: " & oAppt.Subject & " " & oAppt.Organizer
        row = row + 1
    End If
    Set oAppt = oItems.FindNext
Wend
Application.StatusBar = False
You are doing some nice things here. Good Luck!
 

sbendbuckeye

Active Member
Joined
Nov 26, 2003
Messages
440
Hello all,

The example code above is pretty sluggish for any significant number of appointments because the Session object is Created, Logged In and Logged Out every time the method is called. Below is a separate method to create the Session object separately so that the LogIn and LogOut methods can be processed outside the body of the loop. Enjoy...
Code:
Public Function GetMapiSession() As MAPI.Session
    On Error Resume Next
    Set GetMapiSession = CreateObject("MAPI.Session")
    Err.Clear
    On Error GoTo 0
End Function 'GetMapiSession
Code:
' Color corresponds to the ordinal value of the color label.
'   0=None, 1=Important, 2=Business, etc. See not in header regarding label references.
Public Function GetApptColorLabel(objAppt As Outlook.AppointmentItem, _
                                  objMapiSession As MAPI.Session, _
                                  Optional ByVal ReportError As Boolean = False) As Integer
    Const CdoPropSetID1 = "0220060000000000C000000000000046"
    Const CdoAppt_Colors = "0x8214"
    On Error Resume Next
    Dim objField As MAPI.Field
    
    With objMapiSession
        If Len(Trim$(objAppt.EntryID)) > 0 Then
            With .GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)
                Set objField = .Fields.Item(CdoAppt_Colors, CdoPropSetID1)
                If objField Is Nothing Then
                    Err.Clear
                    If ReportError Then MsgBox "Error processing appt " & objAppt.Subject, vbCritical, "Appt Label Error"
                    GetApptColorLabel = 0
                Else
                    GetApptColorLabel = objField.Value
                End If
            End With
        End If
    End With
    Set objField = Nothing
    On Error GoTo 0
End Function 'GetApptColorLabel
Code:
' Color corresponds to the ordinal value of the color label.
'   0=None, 1=Important, 2=Business, etc. See not in header regarding label references.
Public Sub SetApptColorLabel(objAppt As Outlook.AppointmentItem, _
                             intColor As Integer, _
                             objMapiSession As MAPI.Session)
    Const CdoPropSetID1 = "0220060000000000C000000000000046"
    Const CdoAppt_Colors = "0x8214"
    On Error Resume Next
    Dim objField As MAPI.Field
    Dim strMsg As String
    
    With objMapiSession
        If Not objAppt.EntryID = "" Then
            With .GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)
                Set objField = .Fields.Item(CdoAppt_Colors, CdoPropSetID1)
                If objField Is Nothing Then
                    Err.Clear
                    Set objField = .Fields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)
                Else
                    objField.Value = intColor
                End If
                .Update True, True
            End With
        Else
            strMsg = "You must save the appointment before you add a color label. " & _
                     "Do you want to save the appointment now?"
            If vbYes = MsgBox(strMsg, vbYesNo + vbDefaultButton1 + vbQuestion, "Set Appointment Color Label") Then
                Call SetApptColorLabel(objAppt, intColor)
            End If
        End If
    End With
    Set objField = Nothing
    On Error GoTo 0
End Sub 'SetApptColorLabel
 

Watch MrExcel Video

Forum statistics

Threads
1,130,119
Messages
5,640,218
Members
417,131
Latest member
Seanr19871

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top