Forum Post Syndication Engine

This section talks about how to configure the microsoft outlook to use with syndication engine.

1. Define the macro: Open outlook and goto Tools->Macro->Visual Basic Editor
   1. Outlook opens a new window where paste the following
      
      

      Public Const OUTLOOK_ROOT_FOLDER As String = "\\03 Forums"
      Public Const EXPERTS_EXECHANGE_FORUM As String = "www.experts-exchange.com"
      Public Const JAVARANCH_FORUM As String = "saloon.javaranch.com"
      
      ' Folders
      Public Const EXPERTS_EXCHANE_FOLDER As String = "01 Experts Exchange"
      Public Const JAVARANCH_FORUM_FOLDER As String = "04 Java Ranch"
      
      Sub GetInternetHeaders(ByRef olkItem As Outlook.MailItem)
          'Set the error handler to allow us to handle errors in code
          On Error Resume Next
      
          'Declare a few variables
          Dim oSession As Object, _
              oMappedMessage As RDOMail, _
              oFolder As RDOFolder
      
          Set oSession = CreateObject("Redemption.RDOSession")
          oSession.Logon , , False, False, 0
      
          Set oMappedMessage = oSession.GetMessageFromID(olkItem.EntryID, olkItem.Parent.StoreID)
          On Error GoTo errorHandler
          ParseAndAddProperties oMappedMessage, olkItem
          On Error Resume Next
          Err.Clear
          olkItem.Save
          If Err.Number <> 0 Then
              MsgBox ("Unable to save the message: " & Err.Number & ", Description = " & Err.Description)
          End If
          
          
          Set oFolder = FindOrCreateFolder(olkItem, oSession)
          If oFolder Is Nothing Then
              MsgBox ("Unable to create the destination folder.")
          Else
              oMappedMessage.Move oFolder
          End If
          'oMappedMessage.Move (oSession.GetFolderFromPath("\\03 Forums\01 Experts Exchange\Java Programming"))
          'olkItem.Save
      
      errorHandler:
          If Err.Number <> 0 Then
              MsgBox ("General Error, code = " & Err.Number & ", Description = " & Err.Description)
          End If
      
          'Logout of the CDO sesison
          oSession.Logoff
          'Clean up
          Set oSession = Nothing
          Set oMappedMessage = Nothing
          Set oFolder = Nothing
      End Sub
      
      Sub ParseAndAddProperties(ByRef oMappedMessage As Object, ByRef olkItem As Outlook.MailItem)
          Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
          
          Dim strHeader As String, _
              arrHeaders As Variant, _
              varHeader As Variant, _
              bPropertyAdded As Boolean
      
          Err.Clear
          strHeader = oMappedMessage.Fields(CdoPR_TRANSPORT_MESSAGE_HEADERS)
          On Error GoTo errorHandler
          If Err.Number <> 0 Then
              MsgBox ("Error while reading the fields: " & Err.Description)
              Exit Sub
          End If
      
          arrHeaders = Split(strHeader, vbCrLf)
          For Each varHeader In arrHeaders
              bPropertyAdded = False
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Question-ID", "Question")
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Post-Type", "Type")
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Post-ID", "Post ID")
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Post-Forum", "Forum")
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Topic-Area", "Topic Area")
              bPropertyAdded = bPropertyAdded Or AddProperty(olkItem.UserProperties, varHeader, "X-Total-Points", "Points")
              
              If bPropertyAdded = True Then
                  count = count + 1
              End If
                  
              If count >= 6 Then
                  Exit For
              End If
          Next
          
          AddExtraProperties olkItem
      errorHandler:
          If Err.Number <> 0 Then
              MsgBox ("General Error while parsing and setting properties of the message, code = " & Err.Number & ", message = " & Err.Description)
          End If
          Set arrHeaders = Nothing
      End Sub
      
      Sub AddExtraProperties(ByRef olkItem As Outlook.MailItem)
          Dim sPoints As String
          sPoints = olkItem.UserProperties.Find("Points")
          
          If IsNumeric(sPoints) = True Then
              Dim sForumName As String
              sForumName = olkItem.UserProperties.Find("Forum")
              
              If sForumName = EXPERTS_EXECHANGE_FORUM Then
                  If CInt(sPoints) >= 250 Then
                      olkItem.Importance = olImportanceHigh
                  End If
              End If
          End If
          
      End Sub
      
      
      Function AddProperty(ByRef oMailProperties As Outlook.UserProperties, _
                      sHeaderLine As Variant, _
                      sHeaderName As String, _
                      sPropertyName As String, _
                      Optional oUserPropertyType As OlUserPropertyType = OlUserPropertyType.olText) As Boolean
                      
          Err.Clear
          On Error GoTo errorHandler
          AddProperty = False
          Dim sLookupHeader As String
          Dim iKeyLength As Integer
          Dim oProperty As Outlook.UserProperty
          Dim sValue As String
          
          sLookupHeader = LCase(sHeaderName) & ":"
          iKeyLength = Len(sLookupHeader)
          If Left(LCase(sHeaderLine), iKeyLength) = sLookupHeader Then
              sValue = Trim(Mid(sHeaderLine, iKeyLength + 1))
              Set oProperty = oMailProperties.Find(sPropertyName)
              
              If oMailProperties Is Nothing Then
                  MsgBox ("the mail properties are not defined.")
              End If
              If oProperty Is Nothing Then
                  oMailProperties.Add sPropertyName, oUserPropertyType, True
                  Set oProperty = oMailProperties.Find(sPropertyName)
                  If oProperty Is Nothing Then
                      MsgBox ("Could not add new property [Name = " & sPropertyName & "] the message.")
                      Exit Function
                  End If
              End If
              
              If oUserPropertyType = OlUserPropertyType.olNumber Then
                  oProperty.value = CInt(sValue)
              Else
                  oProperty.value = sValue
              End If
              AddProperty = True
          End If
      
      errorHandler:
          If Err.Number <> 0 Then
              MsgBox ("Error while adding header " & sHeaderName & ", Code = " & Err.Number & ", Message = " & Err.Description)
          End If
          Set oProperty = Nothing
      End Function
      
      
      
      Function FindOrCreateFolder(ByRef olkItem As Outlook.MailItem, ByRef oSession As Redemption.RDOSession) As RDOFolder
          Dim sForumName As String
          Dim sTopicArea As String
          Dim sFolderName As String
          
          sForumName = olkItem.UserProperties.Find("Forum")
          sTopicArea = olkItem.UserProperties.Find("Topic Area")
          sFolderName = OUTLOOK_ROOT_FOLDER
          
          If sForumName = EXPERTS_EXECHANGE_FORUM Then
              sFolderName = sFolderName & "\" & EXPERTS_EXCHANE_FOLDER
          ElseIf sForumName = JAVARANCH_FORUM Then
              sFolderName = sFolderName & "\" & JAVARANCH_FORUM_FOLDER
          Else
              ' Keep the messages on the root folder itself.
          End If
          
          If sForumName = EXPERTS_EXECHANGE_FORUM Then
              sFolderName = sFolderName & "\Java Programming"
          Else
              sFolderName = sFolderName & "\" & sTopicArea
          End If
          
          If CreateFolders(sFolderName, oSession) = False Then
              Set FindOrCreateFolder = Nothing
          Else
              Set FindOrCreateFolder = oSession.GetFolderFromPath(sFolderName)
          End If
          
      End Function
      
      Function CreateFolders(ByRef sFolderName As String, ByRef oSession As Redemption.RDOSession) As Boolean
          CreateFolders = False
          Dim sTemp As String
          Dim iIndex As Integer
          
          iIndex = InStr(3, sFolderName, "\")
          Dim oFolder As RDOFolder
          Do While Not sTemp = sFolderName
              If iIndex <= 0 Then
                  sTemp = sFolderName
              Else
                  sTemp = Mid(sFolderName, 1, iIndex - 1)
              End If
              Dim oTempFolder As RDOFolder
              Set oTempFolder = oSession.GetFolderFromPath(sTemp)
              If oTempFolder Is Nothing Then
                  Dim sName As String
                  Dim i As Integer
                  i = InStrRev(sTemp, "\")
                  sName = Mid(sTemp, i)
                  Set oTempFolder = oFolder.Folders.Add(sName)
              Else
                  Set oFolder = oTempFolder
              End If
              iIndex = InStr(iIndex + 1, sFolderName, "\")
              Set oTempFolder = Nothing
          Loop
          CreateFolders = True
          Set oFolder = Nothing
      End Function