XL 2019 Problème de décallage d'images à l'importation

[Airpege]

J'ai fait un petit programme vba pour remplir une plage de cellule avec une image importée (avec rognage et redimensionnement en fonction de la plage), mais des décalages inconsistants apparaissent constamment. Parfois dans un sens parfois dans l'autre, parfois l'image est plus grande ou plus petite que la plage selectionnée

Code vba déclanché par double clic sur une plage contenant un texte précis.

Sub InsertionImage()
    Dim emplacement As Range
    Dim Img As Object
    Dim Imgr, ImgW2, ImgH2, emplr As String
    'Dim ShapeObj As Shape
 
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        'D�finit l'emplacement de l'image
        Set emplacement = ActiveCell.MergeArea
 
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
        Imgr = (Img.Height / Img.Width)
        emplr = (emplacement.Height / emplacement.Width)
     
        With Img.ShapeRange
            .LockAspectRatio = msoTrue
         
             If Imgr >= emplr Then
                .Left = emplacement.Left
                .Top = emplacement.Top 
                .Width = emplacement.Width

                ImgW2 = Img.Width
                ImgH2 = Img.Height
                .LockAspectRatio = msoFalse
                .ScaleHeight (emplacement.Height / Img.Height), msoFalse, msoScaleFromTopLeft
                .PictureFormat.Crop.PictureWidth = ImgW2
                .PictureFormat.Crop.PictureHeight = ImgH2
                .PictureFormat.Crop.PictureOffsetX = 0
                .PictureFormat.Crop.PictureOffsetY = 0
                             
                Else
                .Left = emplacement.Left
                .Top = emplacement.Top
                .Height = emplacement.Height
             
                ImgW2 = Img.Width
                ImgH2 = Img.Height
                .LockAspectRatio = msoFalse
                .ScaleWidth (emplacement.Width / Img.Width), msoFalse, msoScaleFromTopLeft
                .PictureFormat.Crop.PictureWidth = ImgW2
                .PictureFormat.Crop.PictureHeight = ImgH2
                .PictureFormat.Crop.PictureOffsetX = 0
                .PictureFormat.Crop.PictureOffsetY = 0
            End If
             
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
 
End Sub

En desactivant certaiens actions, jeme rend compte que c'est ni l'importantion ni le rognage qui pose proble, mais le redimentionnement, qui ne parait pourtant pas le plus compliqué.
la partie concernée :

With Img.ShapeRange
        .LockAspectRatio = msoTrue

        If Imgr >= emplr Then
                .Left = emplacement.Left
                .Top = emplacement.Top
                .Width = emplacement.Width

          Else
                .Left = emplacement.Left
                .Top = emplacement.Top
                .Height = emplacement.Height
        End if
End with

 

[Robert]

Bonsoir Airpege, bonsoir le forum.

Une autre manière de faire. Fait (dessine) ta sélection et clique avec le bouton droit de la souris sur n'importe quelle cellule de cette sélection...

Le code de l'événementielle BeforeRightClick :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Module1.Macro1
End Sub

Le code de la procédure Macro1 du module Module1 :

Sub Macro1()
Dim S As Range 'Sélection
Dim LS As Double 'Largeur Sélection
Dim HS As Double 'Hauteur Sélection
Dim LI As Double 'Largeur Image
Dim HI As Double 'Hauteur Image

Set S = Selection 'définit la selection S
HS = S.Height 'définit HS
LS = S.Width 'définit LS

If Application.Dialogs(xlDialogInsertPicture).Show Then
    HI = Selection.Height 'définit Hauteur Image
    LI = Selection.Width 'définit Largeur Image
    If HI >= HS Then 'condition : si image plus haute que la sélection
        Selection.ShapeRange.ScaleWidth HS / HI, msoFalse, msoScaleFromTopLeft 'mise à l'échelle
        LI = Selection.Width 're définit Largeur Image
        'si image plus large que sélection, mise à l'échelle
        If LI > LS Then Selection.ShapeRange.ScaleWidth LS / LI, msoFalse, msoScaleFromTopLeft
    Else 'sinon
        Selection.ShapeRange.ScaleWidth LS / LI, msoFalse, msoScaleFromTopLeft 'mise à l'échelle
    End If 'fin de la condition
Else
    MsgBox "Insertion d'image interrompue."
End If
End Sub

 

[Airpege]

Ah oui, l'opérateur sélection est très puissant.

du coup je l'ai adapté à mon cas (rognage en plus de redimentionnement, si double clic) comme ceci

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If InStr(ActiveCell.Value, "Ajout photo") > 0 Then
Call InsertionImage
End If

If InStr(ActiveCell.Value, "Ajouter un composant") > 0 Then
Call Insertioncomposant
End If


End Sub

et

Sub InsertionImage()
Dim S As Range 'Sélection
Dim LS As Double 'Largeur Sélection
Dim HS As Double 'Hauteur Sélection
Dim LI As Double 'Largeur Image
Dim HI As Double 'Hauteur Image

Set S = Selection 'définit la selection S
HS = S.Height 'définit Hauteur Selection
LS = S.Width 'définit Largeur Selection

If Application.Dialogs(xlDialogInsertPicture).Show Then
    HI = Selection.Height 'définit Hauteur Image
    LI = Selection.Width 'définit Largeur Image
   
    With Selection.ShapeRange
    .LockAspectRatio = msoTrue
        If (HI / LI) >= (HS / LS) Then 'condition : si image plus haute que la sélection
            .Width = LS
                HI = Selection.Height 'redéfinit Hauteur Image
                LI = Selection.Width 'redéfinit Largeur Image
            .LockAspectRatio = msoFalse
            .ScaleHeight HS / HI, msoFalse, msoScaleFromTopLeft 'mise à l'échelle
                With .PictureFormat.Crop
                .PictureWidth = LI
                .PictureHeight = HI
                .PictureOffsetX = 0
                .PictureOffsetY = 0
                End With
        Else 'sinon
            .Height = HS
                HI = Selection.Height 'redéfinit Hauteur Image
                LI = Selection.Width 'redéfinit Largeur Image
            .LockAspectRatio = msoFalse
            .ScaleWidth LS / LI, msoFalse, msoScaleFromTopLeft 'mise à l'échelle
                With .PictureFormat.Crop
                .PictureWidth = LI
                .PictureHeight = HI
                .PictureOffsetX = 0
                .PictureOffsetY = 0
                End With
        End If 'fin de la condition
    End With
Else
    MsgBox "Insertion d'image interrompue."
End If
End Sub