Listings

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 &  »  » & 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