Discussion :

[Nicoyong]

Bonjour à tous,
Je programme actuellement une macro qui me permettra de redimensionner et de positionner une photo de façon automatique dans un document Excel. J’ai récupéré cette macro sur le net et je souhaiterais la compléter pour que la photo fasse une rotation de 90° et me propose de la rogner (une pause dans la macro qui me proposera de faire ma sélection de rognage) puis que la macro se finisse.
Pour le moment, je n’ai écris que la ligne qui me permet de faire la rotation mais la photo ne se met pas à l’emplacement que j’ai spécifié et je ne sais pas comment faire pour la partie rognage.
Pouvez-vous m’aider svp.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Sub insere_image_ratio()
    'Déclaration des variables
        Dim ficimg As String
        Dim Ad As String
 
        Dim MemW As Long
        Dim MemH As Long
        Dim t As Integer
        Dim L As Integer
 
        Dim Lg As Integer
        Dim HT As Integer
        Dim RatioCell As Single
 
        Dim CellH As Long
        Dim CellW As Long
        Dim RatioHz As Single
        Dim RatioVt As Single
 
    'Boucle pour supprimer l'ancienne image
        For Each ShapeObj In ActiveSheet.Shapes
            If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
        Next ShapeObj
 
    'Définit l'emplacement de l'image
        Range("A23: f40").Select
        Ad = Selection.Address
        CellH = Selection.Height
        CellW = Selection.Width
 
    'Insertion
        ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
        If ficimg = "Faux" Then Exit Sub
        ActiveSheet.Pictures.Insert(ficimg).Select
 
 
       '__________Ligne suspecte____________________
        Selection.ShapeRange.IncrementRotation 90#
       '_________________________________________ 
    'Adapte les ratio
        With Selection.ShapeRange
            MemW = .Width: MemH = .Height
 
 
 
        'Si la photo < selection
            If MemH < CellH And MemW < CellW Then
                RatioHz = MemH / CellH
                RatioVt = MemW / CellW
 
            'Adapter en hauteur
                If RatioVt < RatioHz Then
                    HT = CellH:  Lg = MemW * (HT / MemH)
                    t = 0: L = (CellW - Lg) / 2
 
            'Adapter en largeur
                Else
                    Lg = CellW: HT = MemH * (CellW / MemW)
                    L = 0: t = (CellH - HT) / 2
                End If
 
        'Si la photo > selection
            ElseIf MemH > CellH And MemW > CellW Then
                RatioHz = CellH / MemH
                RatioVt = CellW / MemW
 
            'Adapter en hauteur
                If RatioVt > RatioHz Then
                    HT = CellH:  Lg = MemW * (HT / MemH)
                    t = 0: L = (CellW - Lg) / 2
 
            'Adapter en largeur
                Else
                    Lg = CellW: HT = MemH * (Lg / MemW)
                    L = 0: t = (CellH - HT) / 2
                End If
 
        'si la hauteur de la photo > hauteur de la selection & largeure  de la photo < largeure de la selection
            ElseIf MemH > CellH And MemW < CellW Then
 
            'Adapter en hauteur
                HT = CellH:  Lg = MemW * (HT / MemH)
                t = 0: L = (CellW - Lg) / 2
 
        'si la hauteur de la photo < hauteur de la selection & largeure  de la photo > largeure de la selection
            ElseIf MemH < CellH And MemW > CellW Then
 
            'Adapter en largeur
                Lg = CellW: HT = MemH * (Lg / MemW)
                L = 0: t = (CellH - HT) / 2
            Else
                Stop ' pas prévu ?
            End If
 
            .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
            .Top = Range(Ad).Top + t ' haut de la cellule
            .Left = Range(Ad).Left + L ' gauche de la cellule
            .Height = HT
            .Width = Lg ' largeur des cellules fusionnées
        End With
 
    'Propriété de la photo
        With Selection
            .Name = "Cible"
            .Placement = xlMoveAndSize
            .PrintObject = True
        End With
End Sub

[cerede2000]

Balaise !
Si quelqu'un à sous le coude un code pour effectuer un rognage avec sélection dynamique sur l'image en macro, je suis preneur
Afin de traiter des photo en masse pour rogner, c'est cool !