Microsoft 365 Insertion Image dans une Feuille et Ratio conservé

[Warlogs44]

Bonjour à tous, chère experts en VBA, je suis ultra novice.

J'ai des soucis pour pour l'implantation d'image. Disons que 95% des Images de mon Document sont au format paysage et 5% au format Portrait.
Jusque là pas de problème je sais lesquels sont censés être à ce format et j'ai ajusté les tailles.

Seulement voilà parfois j'aurais des format Portrait "Non attendu" et là c"est le drame, comme j'ai défini les dimensions.

Critère 1: Je souhaitais insérer plusieurs photos bien défini à des emplacement bien précis (environ 40aine) avec un seul bouton dans mon fichier excel et sous plusieurs onglets.
Du coup je renomme mes photos avec le bon nom avant de lancer la macro.

J'ai fais le choix d'utiliser un chemin relatif car ce fichier excel est dupliqué dans chaque affaire que je traite avec son dossier photo (toujours au même nom quelque soit l'affaire). Je pensais que ça m'éviterais de devoir m'amuser à retaper le chemin dans le code pour chaque dossier. (Et un un autre collaborateur doit pouvoir utiliser le fichier). Je ne sais pas si c'était un bon choix.... vis à vis du code. (peut être qu'amener le chemin du dossier photo dans une case pourrait régler tous mes problèmes?)

Critère2: Je voulais pouvoir supprimer les photos précédentes à chaque fois qu'on appui sur le bouton d'insertion des photos. Dans le cas de modification à apporter ou un rechargement du fait d'un mauvais nom d'image.


Je n'arrive pas à intégrer simplement le .LockAspectRatio = msoTrue dans mon code, ça ne fonctionne pas.

Je risque d'avoir un autre problème ensuite comme les photos ne sont pas positionnées dans des cellules défini mais sur la feuille, c'est que celle en paysage au lieu de Portrait se mettent mal.


ce point me paraissant compliqué, j'ai voulu revoir tout le code pour insérer les photos dans des cellules, pour pouvoir les centrer et conserver le ratio, quelle soit en paysage ou en portrait mais ça ne fonctionne pas non plus.

Voici le code utilisé grâce à des Tuto, pour l'intégration d'une photo, je l'ai dupliqué pour les 40 photos avec les bonnes positions de chacune.

Sub IntegrationImage()

Sub IntegrationImage()

'Déclaration des variables
Dim chemin As String
Dim NomImage As String
Dim image As String

ThisWorkbook.Worksheets("PDG").Select

'Suppression des images précédente de la feuille
    Dim xPicRg As Range
    Dim xPic As Picture
    Dim xRg As Range
    Application.ScreenUpdating = False
    Set xRg = Range("A24:AG62")
    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
    Next
    Application.ScreenUpdating = True
    
'Affectation des variables PHOTO AGENCE
chemin = ThisWorkbook.Path & "\2-Photos visite\"
NomImage = Range("D25")
image = ".jpg"

Range("D25").Value = NomImage

Sheets("PDG").Shapes.AddPicture filename:=chemin & NomImage & image, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=55, Top:=298, Width:=360, Height:=270

Si une âme sensible pouvait m'aider, peut être qu'il ne faut pas grand chose.... ou alors je dois tout revoir

 

[Dudu2]

Bonjour a tous,

Je vais y aller de ma fonction perso d'insertion d'image. On ne sait jamais, ça peut servir.
Y a des paramètres pour placer l'image dans tous les sens qui sont expliqués en commentaire.

 

[Warlogs44]

re patrick toulon
Ça y est eurêka, avec le classeur que tu as posté sur ce fil, j'ai réussi à intégrer ta 'fonction perso patricktoulon dans mes modules. Maintenant c'est fonctionnel

re warlogs44
Je dois avouer que je n'interprète pas votre problème avec la photo que vous postez sur le fil 14.
Je crois comprendre qu'elle apparait à l'envers, si tel est le cas, la raison vient du fait qu'elle a été tourné dans le dossier d'origine. Pourriez vous précisez svp.

Si tel est le cas une solution, vous ouvrez la photo avec "photo filtre", vous "enregistrez sous" la photo orientée comme vous le souhaitez, et dans la boite de dialogue qui suivra, vous décochez garder les données exif. l'orientation images disparaitra des données exif de la nouvelle photo, et de la sorte la photo s'inscrira parfaitement dans la cellule de destination. Tous les logiciels photo qui suppriment le tag d'orientation ferons l'affaire.

En plus les données exif contiennent des informations confidentielles, et vous nous dites dans le message que vous envoyez les photos à des clients, il est peut-être souhaitable de supprimer toutes les données exif avant de les inclure dans le classeur, afin de ne pas partager des données confidentielles
cdt
galougalou

la photo jointe fil 14 est dans le bon sens,

Elle devrait être réduite correctement dans le cadre jaune, mais elle ne l'est pas.

Elle est inséré dans le même sens que dans mon dossier, tel qu'elle devrait être vu.

Rien d'alarmant pour les données EXIF je penses.

 

[GALOUGALOU]

re ok
effectivement les tests que j'ai effectués m'ont mené au même résultat
Les cellules fusionnées sont une plaie dans la gestion des codes.
Il faudrait peut-être se tourner vers un (ou plusieurs) control image dans la feuille. là les photos serait dimensionnées correctement après avoir réglé dans les propriétés le réglage picture size mode sur 1 ou 3
à voir, j'essaierai ce soir
cdt

 

[Warlogs44]

re @GALOUGALOU
Avez vous pu tester mon classeur avec les infos fil 14 ? vous me direz ce que vous en pensez du code utilisé

 

[patricktoulon]

re
effectivement rien du tout !!!!!
si ça déconne c'est chez toi que ça va pas point barre !!
ça n'a rien a voir avec des cellules fusionnées ma fonction gère les fusions
je doute une non rétrocompatibilité sur shaperange (déjà vu)
au quel cas tu envoie non pas un shape mais un object picture dans la sub
chez moi ça fonctionne très bien sur 2007 2013 2016

 

[patricktoulon]

re
c'est bien dans ton fichier que ça ne va pas j'ai testé

 

[patricktoulon]

re
Bon!!!!!!!!!!!!!!!!!!!
alors par quoi je commence ???????
alors tout d'abords comme je m'en doutais!!!!!!!!! il a probleme sur shaperange.lockaspect ration (tu aurais excel 2019 que ça m’étonnerait pas dans ton 365)

ensuite!!!!!
tu ajoute une image de la mauvaise manière avec

.Shapes.AddPicture Filename:=chemin & NomImage & Image, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=55, Top:=298, Width:=360, Height:=270

et oui la bonne blague tu la redimensionne et donc elle perd ses proportions !!!!!!!

donc fort de ces constatations je modifie un peu le truc
j'insert l'image comme tel dans la feuille avec pictures.insert EN TANT QU OBJECT PICTURE (variable(pict))
et je la replace avec ma fonction perso que j'ai mis comme tel que je te l'ai donné dans ton module

voyons voir si ca marche hein ma fonction

hoh!!!! ben saperlipopette alors ca marche

voila le debut du code modifié avant de passer a la feuille (VPA)

Sub PlaceThePictureInCenterRange(rng As Range, Obj As Variant, Optional PercentMarge As Long = 100)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#, Wx#, Yx#
    If rng.Cells(1).MergeCells = True Then Set rng = rng.Cells(1).MergeArea
    Wx = rng.Width * (PercentMarge / 100)
    Yx = rng.Height * (PercentMarge / 100)
    Ratio = Application.Min(Wx / Obj.Width, Yx / Obj.Height)
    With Obj
        If TypeName(Obj) = "Shape" Then .LockAspectRatio = msoTrue Else .ShapeRange.LockAspectRatio = msoTrue
        .Width = .Width * Ratio
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Width - .Width) / 2)
    End With
End Sub

Sub IntegrationImage()

'Déclaration des variables
    Dim chemin As String
    Dim NomImage As String
    Dim Image As String

    ThisWorkbook.Worksheets("PDG").Select
    Dim xPicRg As Range
    Dim xPic As Picture, pict As Picture
    Dim xRg As Range
    Application.ScreenUpdating = False
    Set xRg = Range("A24:AG62")
    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
    Next
    Application.ScreenUpdating = False
    DoEvents

'********************************************************************************
    '!!!!!!!!REGARDE COMMENT JE FAIT ICI ET FAIT PAREIL POUR LES SUIVANTES !!!!!!!!
   
    'Affectation des variables PHOTO AGENCE
    With Sheets("PDG")
        chemin = ThisWorkbook.Path & "\2-Photos visite\"
        NomImage = .Range("D25")
        Image = ".jpg"
        Range("D25").Value = NomImage
        'beurk!!!!.Shapes.AddPicture Filename:=chemin & NomImage & Image, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=55, Top:=298, Width:=360, Height:=270
        Set pict = .Pictures.Insert(chemin & NomImage & Image)
        PlaceThePictureInCenterRange .[D25], pict, 95
    End With
'*********************************************************************************

VOILA

 

[GALOUGALOU]

re le fil
Démonstration magistrale !! Rien à dire
cdt

 

[patricktoulon]

Merci @GALOUGALOU
Ça tombait bien j'ai un pot chez moi qui avait 365 sur son pc portable
j'ai pu revoir le problème de shaperange avec .locskaspectratio j'avais déjà observé le soucis

remarquez que j'injecte dans ma fonction perso [D25] et non l'adress de la fusion
ce qui prouve bien que la fusion est bien prise en compte dans la fonction

pour le reste du code il y en a tant a dire mais je préfère laisser le demandeur faire ces armes a son rythme