Menu

Redimmentionner images outlook pièces jointes [Résolu]

Messages postés
98
Date d'inscription
dimanche 10 novembre 2013
Statut
Membre
Dernière intervention
7 mai 2019
- - Dernière réponse :  zucrezel - 7 mai 2019 à 13:30
Bonjour,

Sur outlook 2010 il y a une option pour redimentionner les images en pièce jointe:
(Redimentionner les images de grande taille lorsque j'envois ce message)
Je souhaiterais l'inclure dans une Macro pour éviter à chaque fois de cliquer dessus.
Est-ce possible?
Afficher la suite 

Votre réponse

2 réponses

0
Merci
Bonjour,

Trouvé sur https://www.slipstick.com/developer/code-samples/resize-images-outlook-email/

Public Sub ResizeImagesReceivedMail()
    Dim objItem As Object
    Dim objInsp As Outlook.Inspector
    
    ' Add reference to Word library
    ' in VBA Editor, Tools, References
    Dim objWord As Word.Application
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
    On Error Resume Next

Dim targetHeight As Integer
Dim oShp As Shape
Dim oILShp As InlineShape
Dim picSize As Variant

' make all images (both inline and floating)
' 13 cm wide while preserving aspect ratio
picSize = 13
   
'Reference the current Outlook item
    Set objItem = Application.ActiveInspector.CurrentItem
    If Not objItem Is Nothing Then
        If objItem.Class = olMail Then
            Set objInsp = objItem.GetInspector
            If objInsp.EditorType = olEditorWord Then
                Set objDoc = objInsp.WordEditor
                Set objWord = objDoc.Application
                Set objSel = objWord.Selection

       With objSel
       ' Formatting code goes here
       
        For Each oShp In objSel.ShapeRange
        With oShp
        .LockAspectRatio = msoTrue
        .Height = AspectHt(.Width, .Height, CentimetersToPoints(picSize))
        .Width = CentimetersToPoints(picSize)
        End With
        Next
        For Each oILShp In objSel.InlineShapes
        With oILShp
        .LockAspectRatio = msoTrue
        .Height = AspectHt(.Width, .Height, CentimetersToPoints(picSize))
        .Width = CentimetersToPoints(picSize)
        End With
        Next 

       End With

            End If
        End If
    End If
    
    Set objItem = Nothing
    Set objWord = Nothing
    Set objSel = Nothing
    Set objInsp = Nothing
End Sub

Private Function AspectHt(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
If origWd <> 0 Then
AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
AspectHt = 0
End If
End Function
Commenter la réponse de zucrezel
0
Merci
Merci infiniment !
Génial !
pense à marquer ce sujet en "résolu" stp.
Commenter la réponse de sormick