XL 2016 VBA Insertion d'une image

danielco · 7 Avril 2020

Bonjour,

J'utilise ce code pour insérer des photos :

VB:

  For Each C In Range("D3", Cells(Rows.Count, 4).End(xlUp))
    Photo = C.Value
    Set Img = ActiveSheet.Pictures.Insert(Chemin & Photo & ".jpg")
    With Img
      .Left = C.Offset(, -2).Left
      .Top = C.Offset(, -2).Top
      .Width = Larg
      If C.Height < .Height Then
        .Height = C.Height
      End If
    End With
  Next C

La ligne :

Code:

 .Left = C.Offset(, -2).Left

devrait aligner la photo sur le bord gauche de la colonne B, or ce n'est pas le cas. Qu'est-ce que j'ai fait de travers ?

Le fenêtre d'exécution donne :

?c.Address
$D$3
?C.Offset(, -2).left
161.25
?img.left
161.25

Merci d'avance.

Daniel

patricktoulon · 9 Avril 2020

re
bon si on considère que toutes tes images pivotées ont la donnéee exif (245)
voila les model ou je prends un raccourci methode en faisant simplement un copypicture de l'image re pivoté sur le sheets pour ne pas avoir a m'ennuyer avec les left et top inversé dans le calcul
model 1 pour faineant de la calbasse

VB:

Private Sub CommandButton1_Click()
    Dim fichier As Variant, img As Picture
    On Error Resume Next
    ActiveSheet.Shapes("img").Delete
    Err.Clear
    fichier = Application.GetOpenFilename("Text Files (*.jpg), *.jpg", 1, "ouvrir un fichier")
    If fichier = False Then Exit Sub
    Set img = ActiveSheet.Pictures.Insert(fichier)
    img.Name = "img"
    place_l_image_dans [C5], img...

danielco · 7 Avril 2020

Il me reste à comprendre pourquoi la 3e image ne se dimensionne pas comme la cellule...

Daniel

patricktoulon · 7 Avril 2020

re
heu ben c'est pas peine d'avoir tenté de te l'expliquer
a tu pris la peine d'aller voir le lien

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

danielco · 7 Avril 2020

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...

Daniel

danielco · 7 Avril 2020

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

Daniel

jmfmarques · 7 Avril 2020

Le scieur de tables basses répond présent, mais uniquement à certaines conditions. La première d'entre elles est que tu ne te contentes pas de dire que tu ne comprends pas pourquoi ton mécanisme est boiteux. Ou tu veux de l'aide et je te parlerai alors d'un mécanisme ad hoc, ou tu insistes à vouloir modifier ton mécanisme et tu le feras alors sans moi.

patricktoulon · 7 Avril 2020

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

c'est tout bonnement impossible ça a été testé re testé dans toute taille et configuration possible c'est toi qui fait une erreur quelque part

Modeste geedee · 7 Avril 2020

Bonsour®

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

est loin de la bonne humeur de feu MPFE ...
voir comme ceci :
!!!!!!!!!!!!!!!!!!!
d'abord s'assurer de l'orientation correcte des photos (notament si issues du monde Apple
!!!!!!!!!!!!!!!!!!!

VB:

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

danielco · 7 Avril 2020

@jmfmarques

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

Ah je croyais être sur un forum d'entraide ? Mais, merci, j'ai la solution, et mon code "boiteux" fonctionne. le problème vient d'un fichier photo curieusement bricolé, merci Modeste. Mais parle-moi d'un "mécanisme ad hoc", @jmfmarques , j'ai envie de voir.

@Modeste geedee :

Ton code fonctionne bien, merci (et sans Merise, encore !) et désolé pour l'humeur, c'est la première fois que j'ai eu l'impression de perdre mon temps, sur ce forum.

Daniel

patricktoulon · 7 Avril 2020

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

jmfmarques · 7 Avril 2020

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.

Modeste geedee · 7 Avril 2020

Bonsour®

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

l'éclairage m'est venu lorsque j'ai constaté que les images étaient pivotées
les images que j'ai utilisées venaient en effet d'un MAC

patricktoulon · 7 Avril 2020

bon danielco
prends ce fichier
clique sur le bouton et choisi un jpg avec le dialog
répète l’opération autant de fois que tu veux avec des image et forme différentes
et dit moi encore que ça marche pas

jmfmarques · 7 Avril 2020

et sans Merise, encore !

wow ...! je me demande bien ce que viendrait faire Merise là-dedans ... Ni de près, ni de très loin !
Bref ...

Modeste geedee · 7 Avril 2020

Bonsour®

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.

Votre participation s'assimile à du "FLAMING"
Le TROLL n'est pas loin !!!
Je ne vous salue pas ...

jmfmarques · 7 Avril 2020

A Modeste geedee : les saluts ne sont pas ma raison de vivre.
J'aurais aimé (mais tel n'a pas été le cas) voir danielco au moins réagir à ceci :

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

Tout cela est bien dommage, car il aurait été conduit à du plus élégant que ce qu'il a maintenant entre les mains.
Mais bon ...

XL 2016 VBA Insertion d'une image

danielco

XLDnaute Accro

patricktoulon

danielco

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

danielco

XLDnaute Accro

danielco

XLDnaute Accro

jmfmarques

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

Modeste geedee

XLDnaute Barbatruc

danielco

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

jmfmarques

XLDnaute Accro

Modeste geedee

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

jmfmarques

XLDnaute Accro

Modeste geedee

XLDnaute Barbatruc

jmfmarques

XLDnaute Accro

Discussions similaires