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

jmfmarques · 8 Avril 2020

Dur de la "comprenure", à ce que je vois
Allez, montre moi ce que tu montrerais en affichant ceci
__
! !
! !
! !
!_!
dans cela :
____________________________
!___________________________!
et en en gardant les proportions
bref .......

job75 · 8 Avril 2020

jmfmarques à dit:
Dur de la "comprenure", à ce que je vois

[En passant] bref je note ce genre de remarque et laisse à l'intéressé le soin de réagir.

jmfmarques · 8 Avril 2020

Bonjour Job75
je suis quant à moi plus simple : j'attends le résultat d'une telle insertion. le reste est perte de temps.

danielco · 8 Avril 2020

Perso, je choisis l'option "sans floodeur".

Daniel

patricktoulon · 8 Avril 2020

re
jmfmarques là encore tu biaise l'orientation de ton raisonnement
relis ma réponse surtout le passage ou je parle d'un rectangle de même hauteur!!!!! que le carré 😉 et non les dimensions inversées🙄

donc voila l'exemple avec rotation (a condition que la donnée excif soit présente bien sur!!)
reste a faire l'inversion logique (.height=rng.height/.height=rng.width)et vice et versa en fonction de rot

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")
    rot = GetImg_Orientation(fichier)
    MsgBox rot
    If fichier = False Then Exit Sub
    Set img = ActiveSheet.Pictures.Insert(fichier)
    img.Name = "img"

    place_l_image_dans [C5], img, Val(rot)



End Sub
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional rot As Long = 0)
    Dim x As Boolean
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        x = (Rng.Width / Rng.Height) < (.Width / .Height)
         .ShapeRange.Rotation = rot
        'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
           If x Then .Width = Rng.Width Else .Height = Rng.Height
             'ci dessous ne fonctionne pas
             'If x Then .Width = IIf(rot < 0, Rng.Height, Rng.Width) Else .Height = IIf(rot < 0, Rng.Width, Rng.Height)
           .Left = Rng.Left    '+ ((Rng.Width - .Width) / 2)'débloquer si l'image doit etre au centre horizontalement
        .Top = Rng.Top    '+ ((Rng.Height - .Height) / 2)'débloquer si l'image doit etre au centre verticalement
        .Placement = 1
        End With
End Sub
Function GetImg_Orientation(fichier) As Long
   Dim Dossier$, img$, Fld As Object, Fich As Object
    Dossier = Mid(fichier, 1, InStrRev(fichier, "\") - 1)
    img = Mid(fichier, InStrRev(fichier, "\") + 1)
    Set shApp = CreateObject("Shell.Application")
    Set Fld = shApp.Namespace(Dossier)
    Set Fich = Fld.items.Item(img)
    GetImg_Orientation = -Val(Replace(Replace(Fld.getdetailsof(Fich, 245), "Pivoter de ", ""), " degrés", ""))
End Function

danielco · 8 Avril 2020

patricktoulon à dit:

re
jmfmarques là encore tu biaise l'orientation de ton raisonnement
relis ma réponse surtout le passage ou je parle d'un rectangle de même hauteur!!!!! que le carré 😉 et non les dimensions inversées🙄

donc voila l'exemple avec rotation (a condition que la donnée excif soit présente bien sur!!)
reste a faire l'inversion logique (.height=rng.height/.height=rng.width)et vice et versa en fonction de rot

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")
    rot = GetImg_Orientation(fichier)
    MsgBox rot
    If fichier = False Then Exit Sub
    Set img = ActiveSheet.Pictures.Insert(fichier)
    img.Name = "img"

    place_l_image_dans [C5], img, Val(rot)



End Sub
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional rot As Long = 0)
    Dim x As Boolean
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        x = (Rng.Width / Rng.Height) < (.Width / .Height)
         .ShapeRange.Rotation = rot
        'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
           If x Then .Width = Rng.Width Else .Height = Rng.Height
             'ci dessous ne fonctionne pas
             'If x Then .Width = IIf(rot < 0, Rng.Height, Rng.Width) Else .Height = IIf(rot < 0, Rng.Width, Rng.Height)
           .Left = Rng.Left    '+ ((Rng.Width - .Width) / 2)'débloquer si l'image doit etre au centre horizontalement
        .Top = Rng.Top    '+ ((Rng.Height - .Height) / 2)'débloquer si l'image doit etre au centre verticalement
        .Placement = 1
        End With
End Sub
Function GetImg_Orientation(fichier) As Long
   Dim Dossier$, img$, Fld As Object, Fich As Object
    Dossier = Mid(fichier, 1, InStrRev(fichier, "\") - 1)
    img = Mid(fichier, InStrRev(fichier, "\") + 1)
    Set shApp = CreateObject("Shell.Application")
    Set Fld = shApp.Namespace(Dossier)
    Set Fich = Fld.items.Item(img)
    GetImg_Orientation = -Val(Replace(Replace(Fld.getdetailsof(Fich, 245), "Pivoter de ", ""), " degrés", ""))
End Function

Merci Patrick,

Mais... sans rotation ? Parce que là, l'image est pivotée...

Daniel

Modeste geedee · 8 Avril 2020

jmfmarques à dit:
1) c'est la fausse solution de Modeste geedee (en plus acceptée comme "solution") que je conteste à grands cris !

en fait dans le code de @danielco, il y avait 2 problémes :
1 - une mauvaise approche dimensionnelle :
- positionnement avant que de régler les dimensions
- application des modifications largeur et hauteur sans avoir clairement identifié réellement les cibles respectives
2 -utilisation d'images auxquelles auraient été appliqué des manipulations préalables.

le point 1 avait me semble-t-il été relevé par les divers participants...

il aura cependant fallu 22 posts #22 avant qu'une proposition aille dans le sens de l'attente du demandeur.
cette "fausse solution" pas très académique il est vrai, avait me semble-t-il une visée à l'apaisement.

l'identification du point 2 permettant à @danielco de comprendre et sortir de cet imbroglio. #42

Mais ce besoin d'avoir le dernier mot m'indispose et je ne pense pas etre le seul.
d'autant que la dénégation du point 2 découle d'un manque d'ouverture.. (d'esprit ???)

nb : votre proposition :

patricktoulon · 8 Avril 2020

bon perso j'ai réglé le problème du sens de l'image reste juste a recalculer le left et top

patricktoulon · 8 Avril 2020

c'est bon pour moi j'ai le redim auto , le rotation calculé auto , le positionnement auto
j'ai pris un raccourci
démo

patricktoulon · 9 Avril 2020

re
Bonjour
Bon alors Danielco a tu résolu ton soucis d'image dans le mauvais sens ?

danielco · 9 Avril 2020

Bonjour,

Pas eu le temps de regarder, hier. Je le ferai aujourd'hui, si possible (bizarrement, avec le confinement, j'ai moins de temps disponible). Je reviens après avoir cherché.

Daniel

patricktoulon · 9 Avril 2020

re
j'en ai 2 de solutions

Staple1600 · 9 Avril 2020

Bonjour le fil

patricktoulon à dit:
re
j'en ai 2 de solutions

Et qu'attends-tu pour les poster dans ce cas? 🙄
Que cela profite à toute la communauté des XLDiens, non ?

patricktoulon · 9 Avril 2020

Bonjour Staple1600
juste de voir si d'autres ont une meilleure solution

Staple1600 · 9 Avril 2020

Bonjour patricktoulon

Euh, je disais cela parce que vous en êtes déjà à 4 pages, les gars ! 😉
Pour insérer une image dans un tableur ...(qui comme chacun sait est sa vocation première 😉)|/ISPOILER]

PS: la présence d'émoticones dans ce message signale que ...celui-ci est rédigé dans un registre d'humour bon enfant de confinement 😉

XL 2016 VBA Insertion d'une image

danielco

XLDnaute Barbatruc

patricktoulon

jmfmarques

XLDnaute Accro

job75

XLDnaute Barbatruc

jmfmarques

XLDnaute Accro

danielco

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

danielco

XLDnaute Barbatruc

Modeste geedee

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

danielco

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Discussions similaires

XL 2016 VBA Insertion d'une image

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency