Parker Software Ltd Homepage
Forum Home Forum Home > Email2DB Email Parser > Scripting > Scripting Samples
  New Posts New Posts RSS Feed: Strip Attachments from All Messages
  FAQ FAQ  Forum Search   Calendar   Register Register  Login Login

Strip Attachments from All Messages

 Post Reply Post Reply
Author
Message
Daniel View Drop Down
Admin Group
Admin Group
Avatar
Technical Director

Joined: 19 Dec 2006
Location: Stoke-on-Trent
Posts: 881
Post Options Post Options   Quote Daniel Quote  Post ReplyReply Direct Link To This Post Topic: Strip Attachments from All Messages
    Posted: 31 Jan 2011 at 3:30am
The below code strips attachments from any message received (by the SMTP Service) and appends the attachment names and paths into the message itself.
 
This script should be used in the Mail Server Options -> Event Scripts.
 
It can be used in the relay or arrival scripts dependant on context.
 

Sub Main()
    ' commands start here
    On Error Resume Next
    Dim msg2 As New Message
    Dim idx As Integer
    Dim idy As Integer
    Dim PlainAttachments As String
    Dim HTMLAttachments As String
    Dim MSGKEY As String
    MSGKEY = UniqueKey
    msg2.Text = MSG.Text
    msg2.PartsBoundary = MSG.PartsBoundary
    msg2.Tag = MSG.Tag
    For idx = 0 To MSG.Headers.Count - 1
        msg2.Headers.Add(MSG.Headers(idx).Name, MSG.Headers(idx).Value)
    Next idx
    For idx = 0 To MSG.Parts.Count - 1
        If Left(Trim(MSG.Parts(idx).ContentDisposition), 10) = "attachment" Then
            MSG.Parts(idx).Attachments(0).Save("C:\attachments\" & MSGKEY & "-" & MSG.Parts(idx).ContentDescription)
            PlainAttachments = PlainAttachments & vbCrLf & "Removed File: \\files\Attachments\" & MSGKEY & "-" & MSG.Parts(idx).ContentDescription
            HTMLAttachments = HTMLAttachments & "<br />Removed File: \\files\Attachments\" & MSGKEY & "-" & MSG.Parts(idx).ContentDescription
        End If
    Next idx
    For idx = 0 To MSG.Parts.Count - 1
        If Not Left(Trim(MSG.Parts(idx).ContentDisposition), 10) = "attachment" Then
            If MSG.Parts(idx).ContentType = "text/plain" Then
                ' append removed items to plain text body
                MSG.Parts(idx).Text = MSG.Parts(idx).Text & PlainAttachments
            ElseIf MSG.Parts(idx).ContentType = "text/html" Then
                ' append to html body
                MSG.Parts(idx).Text = MSG.Parts(idx).Text & HTMLAttachments
            ElseIf Left(Trim(MSG.Parts(idx).ContentType), 21) = "multipart/alternative" Then
                For idy = 0 To MSG.Parts(idx).Parts.Count
                    If MSG.Parts(idx).Parts(idy).ContentType = "text/plain" Then
                        ' append removed items to plain text body
                        MSG.Parts(idx).Parts(idy).Text = MSG.Parts(idx).Parts(idy).Text & PlainAttachments
                    ElseIf MSG.Parts(idx).Parts(idy).ContentType = "text/html" Then
                        ' append to html body
                        MSG.Parts(idx).Parts(idy).Text = MSG.Parts(idx).Parts(idy).Text & HTMLAttachments
                    End If
                Next idy
            End If
            MSG.Parts(idx).Save("C:\temp\part.tmp")
            msg2.Parts.Add("C:\temp\part.tmp")
        End If
    Next idx
    msg2.Save("C:\temp\message.tmp")
    MSG.Peek "C:\temp\message.tmp"
    MSG.Load
 Email2DBAccept = Email2DBAccept
End Sub

Private Function UniqueKey() As String
        Dim T1 As Single
        Dim TS As String
        Dim Hours As Integer
        Dim TM As String
        Dim DOT As Integer
        Dim R As Integer
        Dim RH As String
        On Error Resume Next
        R = Int((4095 * Rnd()) + 1)
        RH = "000" & Hex$(R)
        RH = Right$(RH, 3)
        TM = Str$(Timer)
        DOT = InStr(1, TM, ".")
        If DOT > 0 Then TM = Mid$(TM, 1, DOT + 1)
        T1 = CSng(TM)
        Hours = DateDiff("h", DateSerial(Year(Now), 1, 1), Date(Now))
        T1 = Hours + T1
        TS = Str$(T1)
        If InStr(1, TS, ".") = 0 Then TS = TS & ".0"
        TS = Replace(TS, ".", "")
        TS = Hex$(Val(TS)) & RH
        UniqueKey = TS
    End Function
 
 
Daniel Tallentire
Support
Parker Software
Back to Top
 Post Reply Post Reply

Forum Jump Forum Permissions View Drop Down



This page was generated in 0.156 seconds.
These are the forums for Parker Software, developers of Live Chat Software: WhosOn and Email Automation Software: Email2DB.