faire pivoter une image de remplissage avec la forme

jalmainseb

XLDnaute Nouveau
Bonjour à tous,

J'utilise le code suivant pour insérer une image dans un commentaire :

mypath = ThisWorkbook.Path
myfile = photo.Value
Sheets("Données").Cells(der_lig, 2).AddComment
Sheets("Données").Cells(der_lig, 2).Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft
Sheets("Données").Cells(der_lig, 2).Comment.Shape.ScaleHeight 5.7, msoFalse, msoScaleFromTopLeft
Sheets("Données").Cells(der_lig, 2).Comment.Shape.Fill.UserPicture mypath & "\" & myfile

Ce code fonctionne bien MAIS :
La taille des image étant grosse, je souhaite compresser les images du document à l'aide de la boite de dialogue de compression que je vais chercher avec le code suivant :

Private Sub compresser_Click()
Dim cbc As Office.CommandBarControl
Set cbc = CommandBars.FindControl(ID:=6382)
cbc.Execute
Set cbc = Nothing
End Sub

Mon problème : si j'insère par macro les images, elles ne sont pas reconnues en temps qu'images et donc ne sont pas compressées.

En fait, par macro, la case "Faire pivoter l'effet de remplissage en même temps que la forme" n'est pas cochée.
Si je coche cette case, l'image est bien reconnue en temps que tel et est compressée.

Comment faire pour cocher automatiquement cette case ??? (ou autre solution).

J'ai regardé du côté de la propriété "rotatewithobject", mais je n'arrive pas à m'en servir.


SOS !!!


Merci d'avance


Sébastien
 

PMO2

XLDnaute Accro
Re : faire pivoter une image de remplissage avec la forme

Bonjour,

Voici un exemple contenant la création d'un commentaire avec insertion d'une image et gestion de la transparence et, ce qui vous intéresse, la compression des images.

Le commentaire est créé dans la dernière cellule non vide de la colonne "A". Si la colonne "A" ne contient aucune donnée, le commentaire sera en cellule "A1".
Le fichier image doit, IMPERATIVEMENT, se trouver dans le même dossier que le classeur contenant les macros.

Copiez le code ci-dessous dans un module standard et adaptez, à votre usage, les constantes cernées par des ###

Code:
'###   Constante à adapter. Le fichier image doit être placé   ###
'### dans le même dossier que le classeur contenant les macros ###
Const MON_IMAGE As String = "Montagne.jpg" ' Adapter le nom du fichier image
Const MA_FEUILLE As String = "test"
'##################################################################

Sub AddCommentaire()
Dim Obj As Object
Dim S As Worksheet
Dim R As Range
Dim C As Comment
Dim A$
'--- Vérification de l'existence du fichier ---
A$ = ThisWorkbook.Path & "\" & MON_IMAGE
On Error Resume Next
Set Obj = GetObject(A$)
If Err <> 0 Then
  MsgBox "Le fichier ''" & A$ & "'' est introuvable."
  Exit Sub
End If
On Error GoTo Erreur
'----------------------------------------------
Set S = Sheets(MA_FEUILLE)
Set R = S.Range("a" & S.[a65536].End(xlUp).Row & "")
Set C = R.Comment
If Not C Is Nothing Then C.Delete
Set C = R.AddComment
If Not IsEmpty(R) Then C.Text Text:=R.Value
With C.Shape
  .Width = 300
  .Height = 200
  With .Fill
    .UserPicture A$
      '°°° Pour l'effet de transparence °°°
    .Transparency = 0.65
      '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
  End With
End With
Erreur:
If Not Obj Is Nothing Then Set Obj = Nothing
End Sub

Sub CompressionImage()
Dim C As CommandBarControl
Application.ScreenUpdating = False
For Each C In Application.CommandBars("Picture").Controls
  If TypeOf C Is CommandBarButton Then
    If C.ID = 6382 Then
      Application.SendKeys "{DOWN}{TAB}{UP}{ENTER}{ENTER}", True
      C.Execute
      Exit For
    End If
  End If
Next C
Application.ScreenUpdating = True
End Sub

1) la macro AddCommentaire crée le commentaire
2) la macro CompressionImage compresse les images

Cordialement.

PMO
Patrick Morange
 

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 867
dernier inscrit
XFPRO