none
VB Script to move Outlook XP messages

    Question

  • I am trying to write a VB script in Outlook that will take an email and move it to a public folder and then find that same message in the public folder and move it back to the user's inbox. I have gotten the move from the Inbox to the Public folder done, and the move back, but the macro will not run on messages that arrive in the inbox when Outlook is turned off. When the user turns Outlook on in the morning the macro does not process messages that arrived when Outlook was not running.

     

    1. Determine who the email is sent to and store in a variable 2. Grab the subject of the email 3. Search the public folder until those two variables match and then move that message

     

    You may ask why I am torturing myself in such a manner. It is to fix a bug that MS has caused with Outlook XP and Exchange 2010. If you take a message and move it into a public folder and then move it back to the inbox it is perfectly readable. So I am trying to automate this task. This is the code that I pieced together so far:

     

    Option Explicit

     

    Public WithEvents olinboxitems As Items

    Public WithEvents appOutLook As Outlook.Application

     

    ' True to use the Inbox events

    ' False to use the Rules Wizard script action

    Private Const USE_EVENTS = True

     

    Public Sub Initialize_handler()

        If USE_EVENTS Then

            Set olinboxitems = Project1.ThisOutlookSession.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items

        End If

    End Sub

     

    Private Sub Application_Startup()

        If USE_EVENTS Then

            Dim objNS As NameSpace

            Set objNS = Application.Session

            ' instantiate objects declared WithEvents

            Set olinboxitems = objNS.GetDefaultFolder(olFolderInbox).Items

            Set objNS = Nothing

        End If

        Set appOutLook = ThisOutlookSession.Application

    End Sub

     

    Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

        ' if error, it is usually because Item is not a mailItem (i.e.: meeting request)

        On Error GoTo err

        If USE_EVENTS Then

            convert Item

        End If

        Exit Sub

    err:

        Exit Sub

    End Sub

     

    ' convert (if necessary) a plaintext email by accessing the body

    ' using MAPI and copying it into the Outlook body property.

    Public Sub convert(ByRef mailItem As Outlook.mailItem)

        On Error GoTo err

       

        ' check email properties as they are decoded to allow

        ' opportunities to exit an unnecessary conversion quicker.

        If mailItem.BodyFormat = olFormatUnspecified Or _

           mailItem.BodyFormat = olFormatPlain Then

            Dim bodyText, bodyHTML As String

            bodyText = GetBodyUsingMAPI(mailItem)

            bodyHTML = GetHTMLBodyUsingMAPI(mailItem)

            If Len(bodyHTML) > 0 And _

               InStr(bodyHTML, "<!-- Converted from text/plain format -->") > 0 Then

                mailItem.Body = bodyText

                mailItem.HTMLBody = bodyHTML

                mailItem.BodyFormat = olFormatPlain

                mailItem.Save

            End If

        End If

        Exit Sub

       

    err:

        Exit Sub

    End Sub

     

    Private Function GetBodyUsingMAPI(ByRef item1 As Outlook.mailItem)

        Dim objProps As Object

        Dim objItem As Object

        Dim bodyText As String

       

        On Error GoTo err

        Set objProps = CreateObject("Mapiprop.MAPIPropWrapper")

        objProps.Initialize

       

        Set objItem = item1

        bodyText = objProps.c(objItem, &H1000001E)   ' PR_BODY

        Set objItem = Nothing

       

        objProps.Uninitialize

        Set objProps = Nothing

        GetBodyUsingMAPI = bodyText

        Exit Function

       

    err:

        GetBodyUsingMAPI = ""

        Exit Function

    End Function

     

    Private Function GetHTMLBodyUsingMAPI(ByRef item1 As Outlook.mailItem)

        Dim objProps As Object

        Dim objItem As Object

        Dim bodyText As String

       

        On Error GoTo err

        Set objProps = CreateObject("Mapiprop.MAPIPropWrapper")

        objProps.Initialize

       

        Set objItem = item1

        bodyText = objProps.ReadStreamProp(objItem, &H1013001E)   ' PR_HTML

        Set objItem = Nothing

       

        objProps.Uninitialize

        Set objProps = Nothing

        GetHTMLBodyUsingMAPI = bodyText

        Exit Function

       

    err:

       GetHTMLBodyUsingMAPI = ""

        Exit Function

    End Function

     

    Thursday, August 26, 2010 2:20 PM

Answers