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

 

Answer 1

after the startup, you need to use a For Next loop and run through every message of the inbox.

---

Michael Bauer - MVP Outlook
Category Manager - Easily share your categories