XL 2016 VBA Insertion d'une image

patricktoulon à dit:

re
C'est avec ton code que j'obtiens ce résultat (comme avec le mien). Le problème initial reste entier. Je me demande si ce n'est pas une question de taille de fichier jpg...

VB:

'sub de placement et centrage de l'image  dans la range en parametre tout en respectant son  ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
    Dim ratio#, W#, H#
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        W = Rng.Width       ' width  range
        H = Rng.Height      ' height range
        If (W / H < ratio) Then
            .Width = W - space    'en redimentionant le width le height se redimentionne automatiquement
        Else    'ou
            .Height = H - (space / ratio)    'en redimentionant le height le width se redimentionne automatiquement
        End If
        .Left = Rng.Left + ((Rng.Width - .Width) / 2) ' te reste plus qu'a adapter dette ligne  a ce que tu souhaite
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

Cliquez pour agrandir...

danielco à dit:

Personne ? Le gourou ou le scieur de tables basses ? C'est plus un jeu de quilles qu'un forum d'entraide.
Daniel

Cliquez pour agrandir...

Sub Import()
  Dim Cellule As Range, Chemin As String, Photo As String, Img As Picture, Larg As Double
'********************************************
'------[B1].width renvoie une largeur en caractères de la police du style par défaut !!!!!
'*********************************************
  Larg = [C1].Left - [B1].Left
  Chemin = "E:\Users\Fleurent\Desktop\LIVRE\"

  With ActiveSheet
    For i = .Shapes.Count To 1 Step -1
      .Shapes(i).Delete
    Next i
  End With
  For Each Cellule In Range("D3", Cells(Rows.Count, 4).End(xlUp))
    Photo = Cellule.Value
    Set Img = ActiveSheet.Pictures.Insert(Chemin & Photo & ".jpg")
'*****************************************
'------ il faut modifier les options de ratio avant de toucher aux dimensions !!!
'******************************************
    With Img
        .ShapeRange.LockAspectRatio = msoTrue
'--------------------------
       If Cellule.Height < .Height Then
        .Height = Cellule.Height
      End If
'----------------------
      .Width = Larg
'---------------------
      .Left = [D3].Left
      .Top = Cellule.Top  
    End With
    DoEvents
Next Cellule
End Sub

Ou tu veux de l'aide et je te parlerai alors d'un mécanisme ad hoc

Cliquez pour agrandir...

patricktoulon à dit:

bonsoir Modeste geedee
le lockaspectratio est a true par défaut pas besoins d'y toucher sur MAC je sais pas

Cliquez pour agrandir...

et sans Merise, encore !

Cliquez pour agrandir...

jmfmarques à dit:

Bien, danielco, bien. par ton dernier message :
1) tu confirmes ta volonté de n'accepter que ce qui collerait à ton mécanisme
2) tu fermes définitivement la porte au "scieur de tables basses".
Bonne continuation, donc.

Cliquez pour agrandir...

tu la mets à gauche de la B - la largeur de la A, non ?

Cliquez pour agrandir...