LISTING 2: The ConvertHTMLToDefaultWithAtts Subroutine

Sub ConvertHTMLToDefaultWithAtts(objMsg As MailItem)
    Dim intAtts As Integer
    Dim strFileName As String
    Dim strAttPath As String
    Dim objAtt As Attachment
    Dim strAttList As String
    Dim i As Integer

    ' #### USER OPTION ####
    ' folder where you want to store attachments
    ' from HTML messages
    strAttPath = "C:\temp\"
    If Right(strAttPath, 1) <> "\" Then
        strAttPath = strAttPath & "\"
    End If

    Select Case objMsg.BodyFormat
        Case olFormatHTML, olFormatUnspecified
            intAtts = objMsg.Attachments.Count
            For i = intAtts To 1 Step -1
                Set objAtt = objMsg.Attachments.Item(i)
                strFileName = objAtt.FileName
                If InStr(objMsg.HTMLBody, _
                  "cid:" & strFileName) > 0 Then
                    strFileName = objMsg.Subject & _
                                  " - " & strFileName
                    strFileName = _
                      ValidFileName(strFileName)
                    strFileName = _
                      strAttPath & strFileName
                    objAtt.SaveAsFile strFileName
                    objAtt.Delete
                    If strAttList = "" Then
                        strAttList = vbCrLf & vbCrLf & _
                          "* EMBEDDED ATTACHMENTS *" & _
                          vbCrLf & vbCrLf
                    End If
                    strAttList = strAttList & _
                      "   <file:" & strFileName & _
                      ">" & vbCrLf
                End If
            Next
            objMsg.BodyFormat = olFormatPlain
            objMsg.Body = objMsg.Body & strAttList
            objMsg.Save
        Case Else
            ' RTF or plain text are OK
    End Select

    Set objAtt = Nothing
    Set objMsg = Nothing
End Sub


Function ValidFileName(strText As String)
    ' removes invalid characters
    ' and sets length to max 215
    Dim strBadChars As String
    Dim i As Integer
    Dim intPos As Integer
    Dim strExt As String

    ' remove disallowed characters
    strBadChars = "\/:*?<>|" & Chr(34)
    For i = 1 To Len(strBadChars)
        strText = _
          Replace(strText, Mid(strBadChars, i, 1), "")
    Next

    ' split into name and file extension
    intPos = InStrRev(strText, ".")
    If intPos >= 2 Then
        strExt = Mid(strText, intPos + 1)
        strText = Left(strText, intPos - 1)
    End If

    'clip to allowed length
    strText = Left(strText, 215 - Len(strExt))

    ' reassemble parts
    If intPos >= 2 Then
        strText = strText & "." & strExt
    End If

    ValidFileName = strText
End Function