Remplace au niveau des adresses Email de vos contacts l'option d'envoi au format RTF par "Laisser Outlook décider du meilleur format d'envoi". Utile lorsque vous avec un PDA qui se synchronise.
Lorsque l'adresse Email de votre contact est paramétrée pour envoyer un mail au format RTF celui-ci s'il n'utilise pas OUTLOOK risque de ne pas voir vos pièces jointes.
Cette Macro nécessite REDEMPTION.
http://www.dimastr.com/redemption/download.htmchoisir
Download Developer version c'est une version qui ne peut PAS être intégrée dans un logiciel commercial.
Private Const SEND_RTF_FORMAT = 0 Private Const SEND_PLAINTEXT_FORMAT = 7
Private Const SEND_AUTO_FORMAT = 1
Private Sub ChangeSendingFormat() 'pour changer le format RTF dans les adresses Email.
'Create Michael Bauer
'http://www.vboffice.net/sample.html?mnu=2&smp=32&cmd=showitem
'Update Oliv' 2/10/2006
On Error GoTo cleanUp Dim Session As Redemption.RDOSession
Dim Utils As Redemption.MAPIUtils Dim obj As Redemption.RDOMail
Dim Items As Redemption.RDOItems Dim AdrID As Variant Dim PropID As Long
Const GUID As String = "{00062004-0000-0000-C000-000000000046}"
' An bestehende Session einloggen
Set Session = CreateObject("Redemption.RDOSession")
'decommenter les 2 lignes suivantes et remplacer pour utilisation
'avec un compte exchange différent du profil
'user = InputBox("Nom de l'utilisateur", "compte exchange", "TOTO")
'Session.LogonExchangeMailbox user, "serveur"
'Commenter la ligne suivante si les 2 dessus sont décommentées
Session.Logon
'Exemple pour un dossiers public
'Set Items = Session.Stores.Item("Dossiers publics").IPMRootFolder.Folders("Favoris").Folders("Contacts GSR").Items
' Dossier par default
Set Items = Session.GetDefaultFolder(olFolderContacts).Items
If Items.Count Then
Set Utils = CreateObject("Redemption.MapiUtils") ' Einmalig irgendein Objekt abrufen, um die
' PropertyID ermitteln zu können
' ID für Email1EntryID
For i = 1 To 3 '-32603 To -32635 Step -16
Select Case iCase 1 Const ID1 = &H8085
ID = ID1
Case 2 ' Email2EntryID = &H8095
Const ID2 = &H8095
ID = ID2
Case 3 ' Email3EntryID = &H80A5
Const ID3 = &H80A5
ID = ID3
End Select
Set obj = Items(1) PropID = Utils.GetIDsFromNames(obj, GUID, ID)
PropID = PropID Or &H102
' Sendeformat einer EMail-Adresse für alle
' Kontakte ändern
For Each obj In Items If TypeOf obj Is Redemption.RDOContactItem Then
AdrID = Utils.HrGetOneProp(obj, PropID)
If Not IsEmpty(AdrID) Then
If AdrID(22) =SEND_RTF_FORMAT Then
'commenter pour ne pas avoir le msgbox
MsgBox obj & vbCr & AdrID(22)
AdrID(22) = SEND_AUTO_FORMAT
Utils.HrSetOneProp obj, PropID, AdrID, True
End If
End If
End If
Next
Next i End If
cleanUp:
If Not Session Is Nothing Then
Session.Logoff
End If
MsgBox "fin"
End Sub
![[/\]](/infusions/fusionboard4/images/go-top.png "haut de page")
Copyright JièL / Jean-Louis Goubert © 2003-2009 
