Insérer des images à partir de leurs noms
Bonjour GVIALLES,
SUPER!
Grâce à la sélection des deux méthodes d'insertion d'images, celles-ci peuvent co-habitées sans conflit.
Je vous remercie infiniment pour votre aide et surtout pour votre patience.
Je vous souhaite une bonne fin de journée.
Sincères salutations,
Renaud D.
Bonjour GVIALLES,
Je suis désolé de vous importuner à nouveau. J'ai fait aujourd'hui de nombreux tests avec votre macro et j'ai constaté un léger problème d'exécution lorsque la feuille "MODEL" est copiée.
Lorsque je copie la feuille "MODEL", votre macro (sélection des méthodes) fonctionne très bien dans la copie mais ne fonctionne plus correctement dans la feuille "MODEL".
Dans l'exemple, ci-joint (fichier : Exemple 6_RD.xlsm), la sélection par les deux méthodes fonctionne correctement dans la feuille "MODEL(2)". Cependant, dans la feuille "MODEL", il n'est plus possible de choisir entre les deux méthodes et une seule est disponible. J'ai constaté que la sélection par les deux méthodes fonctionne bien uniquement avec la feuille située à l'extrême gauche.
La feuille "MODEL" est destinée à être copiée plusieurs fois et la sélection de la méthode d'insertion d'images doit se faire selon les deux méthodes dans chacune des feuilles copiées (édition éventuelle des images) peu importe la position dans l'ensemble des feuilles.
Au plaisir de vous lire,
Sincères salutations,
Renaud D.
Bonjour Renaud,
Plusieurs problèmes sont à résoudre pour réaliser ce que tu veux faire : copier la feuille "MODEL" en autant de feuilles que nécessaire:
- Les plages nommées doivent se référer à la feuille et non au classeur comme actuellement pour "MODEL" :
- Toutes les macros doivent être sorties de la feuille "MODEL" pour être insérer dans le module1
-Le code VBA doit être revue pour s'adapter au nouveau contexte et se référer à la feuille active et non au classeur dans son ensemble. A titre d'exemple, pour la macro "Méthode2", remplacer les références "Thisworkbook.Names" par "ActiveSheet.Names". Pour les codes VBA de la "Méthode1", il y a plus de travail...
Bonjour GVIALLES,
Je comprends la situation.
Merci beaucoup pour vos explications.
Sincères salutations,
Renaud D.
Bonjour GVIALLES,
J'ai fait des modifications en fonction de vos observations et ça fonctionne.
Mon seul soucis concerne le maintien des proportions de l'image insérée dans le cadre.
Lorsque j'insère une image horizontale, celle-ci s'intègre parfaitement au cadre.
Cependant, lorsque j'insère une image verticale, les proportions de l'image ne sont plus respectées.
L'image doit être ajustée selon sa hauteur (cadre) et la largeur doit être définie selon ses proportions et ne pas être "aplatie".
SVP, pourriez-vous modifier votre code ci-dessous afin de tenir de celà :
If oFS.Fileexists(sImageFileName) Then
'On charge l'image dans la boite voulue
On Error Resume Next
Set oShape = ActiveSheet.Shapes(sCadreImageName)
If Not oShape Is Nothing Then
lLeft = oShape.Left
lTop = oShape.Top
lWidth = oShape.Width
lHeight = oShape.Height
oShape.Delete
Set oShape = ActiveSheet.Shapes.AddPicture(sImageFileName, msoFalse, msoTrue, lLeft, lTop, lWidth, lHeight)
oShape.Name = sCadreImageName
Else
'Récupération du cadre de l'image
Set oRange = Target.Offset(1)
lLeft = oRange.Left
lTop = oRange.Top
lWidth = oRange.MergeArea.Width
lHeight = oRange.MergeArea.Height
Set oShape = ActiveSheet.Shapes.AddPicture(sImageFileName, msoFalse, msoTrue, lLeft, lTop, lWidth, lHeight)
oShape.Name = sCadreImageName
End If
Merci à l'avance pour votre précieuse collaboration.
Sincères salutations,
Renaud D.
Bonjour Renaud,
Pour conserver les proportions des images dans les cadres, je te propose la solution suivante :
- on copie l'image à un emplacement "neutre" de la feuille pour récupérer la largeur et la longueur initiales de l'image.
- on supprime cette image
- on applique la proportionnalité à l'image copiée à l'emplacement adéquat.
Ce qui donne :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oCellsCodesImages As Name
Dim oFS As Object
Dim oShape As Shape, oRange As Range
Dim oShapeRange As ShapeRange
Dim lTop As Double
Dim lWidth As Double
Dim lHeight As Double
Dim lLeft As Double
Dim lPurcentage As Double
Dim sPictureName As String
Dim sImageFileName As String, sCadreImageName As String, sPath As String
Dim oChoix As Range
Set oChoix = ThisWorkbook.Names("ChoixMethode").RefersToRange
If oChoix.Value = 2 Then
Set oFS = CreateObject("Scripting.FileSystemObject")
'On s'assure que le dossier d'images existe
sPath = ThisWorkbook.Names("Dossier_Images").RefersToRange.Value
If Not oFS.Folderexists(sPath) Then
MsgBox "Le dossier images n'a pas été trouvé!"
Exit Sub
End If
'On s'assure que la cellule modifiée est une cellule de la plage "Codes_Images"
Set oCellsCodesImages = ThisWorkbook.Names("Codes_Images")
If InStr(1, oCellsCodesImages.RefersTo, Target.Address) > 0 Then
'On affecte le nom du cadre d'image
sCadreImageName = "img" & Replace(Target.Address, "$", "")
'On supprime le cadre d'image si il existe
On Error Resume Next
Set oShape = ActiveSheet.Shapes(sCadreImageName)
If Not oShape Is Nothing Then
oShape.Delete
End If
On Error GoTo 0
'Si la valeur saisie n'est pas vide, on récupère l'image
If Not IsEmpty(Target.Value) Then
sImageFileName = sPath & "\" & Target.Value & ".jpg"
'On s'assure que le fichier existe
If oFS.Fileexists(sImageFileName) Then
'On charge l'image dans un emplacement neutre pour récupérer les proportions puis supprimer l'image
Set oRange = ActiveSheet.Cells(1, 14)
oRange.Select
With ActiveSheet.Pictures.Insert(sImageFileName)
sPictureName = .Name
End With
ActiveSheet.Pictures(sPictureName).Select
Set oShapeRange = ActiveSheet.Pictures(sPictureName).ShapeRange
With oShapeRange
lHeight = .Height
lWidth = .Width
If .Rotation = 0 Then
lPurcentage = lHeight / lWidth
Else
lPurcentage = lWidth / lHeight
End If
.Delete
End With
'On charge l'image à l'emplacement voulu
Set oRange = Target.Offset(1)
lLeft = oRange.Left
lTop = oRange.Top
'On applique la proportionalité aux dimension de l'image chargée
If lPurcentage > 1 Then
lWidth = oRange.MergeArea.Width / lPurcentage
lHeight = oRange.MergeArea.Height
Else
lWidth = oRange.MergeArea.Width
lHeight = oRange.MergeArea.Height * lPurcentage
End If
Set oShape = ActiveSheet.Shapes.AddPicture(sImageFileName, msoFalse, msoTrue, lLeft, lTop, lWidth, lHeight)
oShape.Name = sCadreImageName
'On encadre l'image
With oShape.Line
.Weight = 0.75
End With
Else
MsgBox "L'image '" & Target.Value & ".jpg' n'existe pas dans le dossier images choisi!"
End If
End If
Target.Select
End If
End If
End SubBonsoir GVIALLES,
J'ai fait quelques légères modifications à votre code afin d'obtenir exactement le résultat désiré.
Je tiens particulièrement à vous remercier pour votre beau travail et surtout pour votre patience.
Sincères salutations,
Renaud D.
Merci Renaud de votre message,
L’important est à mes yeux que tu ais la maîtrise de ce que tu produits.