Date   : Wed, 11 Nov 2009 16:07:30 -0000
From   : mu.list@... (Mark Usher)
Subject: Mail list reply code for Outlook.

Below is some code for Outlook 2007. It should be ok back to Outlook 2003.
Can be pasted into VBA within Outlook. Then set up a rule, 
Where the following is contained in the header.
List-Id: BBC Micro & related machines <bbc-micro.lists.cloud9.co.uk>
And "Run script" 

and the Reply_list_rule will be in the list to select.

You may need to alter your Macro security settings for it to run.

Unfortunately, Outlook doesn't work with a combination of rules and VBA very
well. Grrrrrr. So, if you have a rule to move your BBC mail items to a
folder that won't work. So the script also moves items to a folder of your
choosing.

Additionally, any mails that arrive, that aren't in plain text, get
converted. 

the Internet Headers are not available directly to VBA code without
installing CDO or other COM extensions, so it is not possible to parse the
extra List headers etc for a reply address and take out the hard coded
address. 2nd Grrrrrr

Anyway, hope this is useful to someone, and it saves the messing about with
extra buttons, disabling them, and remembering to click the correct one when
replying.


-Mark



Sub Reply_list_rule(objItem As MailItem)

    Dim strAddress As String
    Dim destFldr As MAPIFolder
        
    Set objDestFld = GetFolder("BBC email\Inbox")
      
    If objItem.Class = olMail Then
        strAddress = "BBC Micro List <bbc-micro@...>"
                    
        ' remove any existing recipients
        While (objItem.ReplyRecipients.Count > 0)
                objItem.ReplyRecipients.Remove (1)
        Wend
        
        ' add the reply address
        objItem.ReplyRecipients.Add (strAddress)
    End If
    
    objItem.ReplyRecipients.ResolveAll
    
    'set to plain text
    objItem.BodyFormat = olFormatPlain
    objItem.Save

    'move to folder
    If Not objDestFld Is Nothing Then
         objItem.Move objDestFld
    End If
        
    Set objDestFld = Nothing
    Set objItem = Nothing
    
End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function