Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 VBA Insertion d'une image

D

danielco

XLDnaute Accro
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
 
Solution
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...
Trier par date Trier par votes
J

jmfmarques

XLDnaute Accro
danielco à dit:
Je patauge toujours autant. Je déclare forfait.

Daniel
Cliquez pour agrandir...
Tu pataugeras moins, ami, lorsque tu sauras mettre dans deux paniers différents :
1) la mise dans le bon sens d'images à traiter
et
2) l'insertion, toutes proportions gardées, d'une image, telle qu'elle est, dans le rectangle d'une cellule

ne pas sérier contribue d'une manière générale, sinon à l'égarement, tout au moins au traitement d'un problème autre que le principal (celui exposé).
 
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
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, Val(GetImg_Orientation(fichier))
End Sub
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional rot As Long = 0)
    Dim x As Boolean
    Application.ScreenUpdating = False
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        Shp.ShapeRange.Rotation = rot: .CopyPicture: ActiveSheet.Paste: .Delete
    End With
    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        x = (Rng.Width / Rng.Height) < (.Width / .Height)
        .Name = "img"
        If x Then .Width = Rng.Width Else .Height = 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, Fich
    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


model 2 pour les moins fainéants de la calbasse
VB: 
Private Sub CommandButton2_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_dans2 [C5], img, Val(GetImg_Orientation(fichier))
End Sub

Sub place_l_image_dans2(Rng As Range, Shp As Picture, Optional rot As Long = 0)
    Dim x As Boolean, leftmoins&, topmoins&
    Application.ScreenUpdating = False
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
         If rot = 0 Then
            If Shp.Height > Rng.Height Then Shp.Height = Rng.Height
            If Shp.Width > Rng.Width Then Shp.Width = Rng.Width
         Else
           Shp.ShapeRange.Rotation = rot:
        If Shp.Width > Rng.Height Then Shp.Width = Rng.Height
        If Shp.Height > Rng.Width Then Shp.Height = Rng.Width
       leftmoins = Abs(.Width - .Height) / 2
       topmoins = Abs(.Height - .Width) / 2
       End If
  .Left = (Rng.Left - leftmoins)
  .Top = (Rng.Top + topmoins)
 End With
End Sub
Private Function GetImg_Orientation(fichier) As Long
    Dim Dossier, img, Fld, Fich
    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





 
Vote positif 0 Vote négatif
Solution

patricktoulon

XLDnaute Barbatruc
si le msgbox est vide ca veux dire que la donnée exif n'y est pas et la on peut rien faire
si j'ai -270 ou -180 ou -90 ca veux dire que j'avais la même chose en positif dans les données exif

Alors oui il est possible d'avoir une donnée exif alors que l'image n'est pas pivotée
tout simplement parce qu'elle a été retouchée avec un logiciel de M....
comme par exemple la visionneuse W7 qui permet de pivoter et sauve l'image mais ne change pas la donnée exif (la bonne blague ) LOL
 
Vote positif 0 Vote négatif

Modeste geedee

XLDnaute Barbatruc
les métadonnées Exif ne sont pas une norme officielle!!!
elles sont inscrites lors de la prise de de vue numérique. (selon le bon vouloir du fabriquant)
et ne concernent que quelques types de format
il existe des logiciels "tiers" qui permettent de créer, modifier ou effacer les données Exif

Concernant le problème initial , les dimensionnement et centrage ne sont pas compliqués en utilisant un contenant image OCX selon paramètres Clip, zoom ou stretch
Hélas pas de pivotement possible.
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
Microsoft 365 Déplacement Shape
Réponses
2
Affichages
198
Cédric06400
L
  • Question
Microsoft 365 Macro Insertion image dans cellule
Réponses
3
Affichages
786
Dranreb
  • Question
XL 2021 coller une image interne au classeur
2 3
Réponses
33
Affichages
1 K
Jouxte
F
  • Question
Microsoft 365 Changement de fonctionnement d'une macro suite au passage à windows 10
Réponses
1
Affichages
452
francha62
F
  • Question
XL 2021 Orientation d'une image dans le commentaire d'une cellule
2 3
Réponses
42
Affichages
2 K
AtTheOne
S
  • Question
Microsoft 365 Enregistrer les images dans un dossier
Réponses
2
Affichages
264
Simon 1234
S
T
  • Résolu(e)
Microsoft 365 Insérer une image DANS une cellule
Réponses
12
Affichages
667
Thomi
T
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
648
crocrocro
C
  • Question
Microsoft 365 Erreur d'exécution 5 argument ou appel de procédure incorrect avec ActiveSheet.ChartObjects.Add()
Réponses
12
Affichages
638
pmfontaine
T
  • Question
Microsoft 365 Images ne s'affiche pas dans fichier Excel
Réponses
5
Affichages
879
job75
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…