VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ProcessWebFeedback"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public myOlApp As Outlook.Application
Attribute myOlApp.VB_VarHelpID = -1
Public WithEvents myOlItems As Outlook.Items
Attribute myOlItems.VB_VarHelpID = -1
Private Sub Class_Initialize()
' Initialise event handler

' You can change the folder name in the next line if you want to
Const NameOfFolder As String = "Web site feedback"

    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlItems = _
    myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders.Item(NameOfFolder).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)

' Adds the content of the first attachment to the body of
' the message (if attachment is text)and then deletes first
' attachment from message. Assumes format of message is:
' name=Eric+Smith&email=esmith@flobadob.co.uk&comments=Here+is+an+email+sent+from+a+form+on+my+Web+site
' ...and pretties it for easier reading

Dim myAttachments As Attachments
Dim i, t As Long
Dim ReadStatus As Boolean
Dim AttachmentFileName, TempString1, TempString2 As String
Dim Replacements() As Variant
                    '    "Search for", "replace with"
    Replacements = Array("+", " ", _
                        "%2b", "+", _
                        "name=", "NAME: ", _
                        "&email=", vbCr + "EMAIL: ", _
                        "&comments=", vbCr + "COMMENTS" + vbCr)

    ' Get handle on Attachments object
    Set myAttachments = Item.Attachments
    
    ' Error checking - make sure only one attachment...
    If myAttachments.Count <> 1 Then
        MsgBox ("Message not processed - require exactly one attachment")
        Exit Sub
    End If
    ' ...and that it's called POSTDATA.ATT
    If UCase(myAttachments.Item(1).DisplayName) <> "POSTDATA.ATT" Then
        MsgBox ("Message not processed - attachment must be called POSTDATA.ATT")
        Exit Sub
    End If
       
     ' Seem only to be able to modify message if it is opened
    ReadStatus = Item.UnRead
    Item.Display
       
    ' Save attachment to disk in C:\
    AttachmentFileName = "C:\" & myAttachments.Item(1).DisplayName
    myAttachments.Item(1).SaveAsFile AttachmentFileName
            
    ' Open attachment file and read its contents into TempString1
    Open AttachmentFileName For Input As #1
    TempString1 = "***** ATTACHMENT CONTENT *****" + vbCr
    
    Do While Not EOF(1)
        Line Input #1, TempString2
        TempString1 = TempString1 + TempString2
    Loop
    
    Close #1                ' Close disk file
    Kill AttachmentFileName ' And delete it
    
    ' Now process contents of TempString1
    ' Loop for each pair of find/replace items in Replacements array...
    For i = LBound(Replacements) To UBound(Replacements) Step 2
        ' Cater for multiple finds (e.g. all those + symbols)
        Do While True ' Would loop forever, but...
            t = InStr(UCase(TempString1), UCase(Replacements(i)))
            If t = 0 Then Exit Do ' ...quits loop when no more found
            ' Otherwise splice replacement text into place
            TempString1 = Left(TempString1, t - 1) + _
                Replacements(i + 1) + _
                Right(TempString1, Len(TempString1) - t - Len(Replacements(i)) + 1)
        Loop
    Next
        
     ' Add carriage return to existing body text, if there is any
    If Item.Body <> "" Then Item.Body = Item.Body + vbCr
    
    ' Add attachment text to body
    Item.Body = Item.Body + TempString1
    
    ' Delete attachment. Could remove this line of you want to play safe
    myAttachments.Item(1).Delete

    ' Close message & save changes without prompting
    Item.Close (olSave)
    
    ' Restore its original read/unread status
    Item.UnRead = ReadStatus

End Sub

