Strip Attachments from All Messages

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