title: VBA Outlook Programming
body: <p>Here is what I am trying to achieve.</p>
  
  <p>My BlackBerry adds appointments into my diary automatically.</p>
  
  <p>I then want to, automatically on the creation of the calendar item:</p>
  
  <p>1)     Pick up any appointment with the prefix "C. "</p>
  
  <p>2)     Categorize the appointment based on appointment location;  'incoming call' and 'outgoing call' = category "call" , 'missed call' = category "missed call"</p>
  
  <p>3)     Rename the appointment removing the "C. " prefix</p>
  
  <p>4)     Move any appointments now in the "call" category to a sub calendar called "Call Log"</p>
  
  <p>5)    I want this process to start automatically when a new appointment is added rather than manual macro or reminder driven.</p>
  
  <p>I have tried amending the below processes found elsewhere on the web .... but not working for me.</p>
  
  <pre><code>Private Sub Application_Reminder(ByVal Item As Object)
  If Item.subject = "Process Calls" Then
  ' Define variables
  Dim objCalendar As Outlook.folder
  Dim objItems As Outlook.Items
  Dim objAppt As Outlook.AppointmentItem
  Dim strRestriction As String
  Dim objFinalItems As Outlook.Items
  Dim myolApp As Outlook.Application
  ' Set strRestriction to be only calls
  strRestriction = "@SQL= (""urn:schemas:httpmail:subject"" LIKE '@Call.%' OR ""urn:schemas:httpmail:subject"" LIKE 'C.%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call in%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call%') AND ""urn:schemas-microsoft-com:office:office#Keywords"" 'Phone call'"
  ' Set the objCalendar and objItems items
  Set objCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
  Set objItems = objCalendar.Items
  Set objFinalItems = objItems.Restrict(strRestriction)
  Set myolApp = CreateObject("Outlook.Application")
  For Each objAppt In objFinalItems
  ' Debugging
  ' Debug.Print objAppt.Start, objAppt.Subject, objAppt.Categories
  ' Assign the category to the appointments
  If objAppt.Location = "Missed Call " Then
  objAppt.Categories = "S. CALL MISSED."
  ElseIf objAppt.Location = "Incoming Call " Then
  objAppt.Categories = "S. CALL RECEIVED."
  Else
  objAppt.Categories = "S. CALL MADE."
  End If
  objAppt.Save
  Next
  ' Rename Entry
  Dim iItemsUpdated As Integer
  Dim strTemp As String
  iItemsUpdated = 0
  For Each aItem In objCalendar.Items
  If Mid(aItem.subject, 1, 2) = "C." Then
  strTemp = Mid(aItem.subject, 4, Len(aItem.subject) - 4)
  aItem.subject = strTemp
  iItemsUpdated = iItemsUpdated + 1
  End If
  aItem.Save
  Next aItem
  MsgBox iItemsUpdated &amp; " of " &amp; objCalendar.Items.Count &amp; " Meetings Updated"
  End If
  End Sub
  </code></pre>
  
  <hr>
  
  <pre><code>Private Sub Application_Reminder(ByVal Item As Object)
  If Item.subject = "Move Calls" Then
  Public Sub MoveACallLog()
  Dim objOL As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim objAppt As Outlook.Items
  Dim objFolder As Outlook.MAPIFolder
  On Error Resume Next
  Set objOL = CreateObject("Outlook.Application")
  Set objNS = objOL.GetNamespace("MAPI")
  Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
  Set objAppt = objFolder.Items
  ' move to a calendar in an archive data file
  Set CalFolder = GetFolderPath("\\stephen@gazard.net\Calendar\Call Log")
  For i = objAppt.Count To 1 Step -1
  If objAppt(i).Categories = "Calls" Then
  objAppt(i).Move CalFolder
  End If
  Next i
  Set objAppt = Nothing
  Set objFolder = Nothing
  Set objOL = Nothing
  Set objNS = Nothing
  End Sub
  Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
  Dim oFolder As Outlook.folder
  Dim FoldersArray As Variant
  Dim i As Integer
  On Error GoTo GetFolderPath_Error
  If Left(FolderPath, 2) = "\\" Then
  FolderPath = Right(FolderPath, Len(FolderPath) - 2)
  End If
  'Convert folderpath to array
  FoldersArray = Split(FolderPath, "\")
  Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
  If Not oFolder Is Nothing Then
  For i = 1 To UBound(FoldersArray, 1)
  Dim SubFolders As Outlook.Folders
  Set SubFolders = oFolder.Folders
  Set oFolder = SubFolders.Item(FoldersArray(i))
  If oFolder Is Nothing Then
  Set GetFolderPath = Nothing
  End If
  Next
  End If
  'Return the oFolder
  Set GetFolderPath = oFolder
  Exit Function
  GetFolderPath_Error:
  Set GetFolderPath = Nothing
  Exit Function
  End Function
  Function GetCurrentItem() As Object
  Dim objApp As Outlook.Application
  Set objApp = Application
  On Error Resume Next
  Select Case TypeName(objApp.ActiveWindow)
  Case "Explorer"
  Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
  Case "Inspector"
  Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
  End Select
  Set objApp = Nothing
  End Function
  </code></pre>