> 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 cette ressource

Microsoft 365 : HP Subscription Management Services en détail

Microsoft 365 : HP Subscription Management Services en détail

Collaboration à distance, environnements de travail et productivité optimisés, gestion évolutive des licences, accélérez la transformation de votre business pour le faire entrer dans l’ère de la collaboration hybride. Découvrez comment le service de gestion des abonnements HP peut vous aider à optimiser vos investissements et votre stratégie de gestion de vos abonnements Microsoft 365.

Tech - Par iTPro - Publié le 24 juin 2010