> Tech > Listings

Listings

Tech - Par iTPro - Publié le 24 juin 2010
email

LISTING 1: La sous-routine ConvertHTMLToDefault

Sub ConvertHTMLToDefault(objMsg As MailItem)
  Select Case objMsg.BodyFormat
    Case olFormatHTML, olFormatUnspecified
      objMsg.BodyFormat = olFormatPlain
      objMsg.Save
    Case Else
      ‘ RTF or plain text are OK
  End Select
  Set objMsg = Nothing
End Sub

LISTING 2: La sous-routine ConvertHTMLToDefaultWithAtts
Sub ConvertHTMLToDefaultWithAtts(objMsg As MailItem)
  Dim intAtts

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

Téléchargez gratuitement cette ressource

Guide de Cloud Privé Hébergé

Guide de Cloud Privé Hébergé

Comment permettre aux entreprises de se focaliser sur leur cœur de métier, de gagner en agilité, réactivité et résilience en s’appuyant sur un socle informatique performant, évolutif et sécurisé ? Découvrez les avantages des solutions de Cloud Privé hébergé de la CPEM.

Tech - Par iTPro - Publié le 24 juin 2010