Re : Nommer une Image par VBA avec recupération du nom dans une cellule
Bonjour Martial
Désolé j'étais parti ces derniers temps ! merci nickel
Tout d’abord bonne année et meilleurs voeux a tous
Juste pour infos j'essaye de modifier ta macros pour la réutilisé mais ce coup ci pour copié une sélection de cellules au format image etc
Voici mon code modifié mais je bloque à différents endroits (passage en gras) sur la partie 1
*j'ai voulu remplacé ton code d'origine:
Sheets("Créationpoinçon").Select par
Sheets("CréationParcours").Range("B6:J11").Select
*j'ai voulu remplacé ton code d'origine:
Set s = ActiveSheet.Shapes("Poinçon")
Set s =et la je ne sais pas quoi mettre
Sub CréationParcours()
' Définition des variables de la feuille Créationpoinçons pour cette macro:
Dim Lieu$, Parcours&, Répertoire$, Parcours2 As Shape, x
Dim Col&, Lig&, Fichier$, ImageExiste As Boolean
'Sheets("CréationParcours").Range("B6:J11").Select est la sélection que je souhaite transformer en image
Lieu = [E4]
Parcours = [J9]
Parcours2 = [K2]
Répertoire = ThisWorkbook.Path
'Si le répertoire au nom de Lieu n'existe alors on le crée
If Dir(Répertoire & "\Parcours", 16) = "" Then MkDir (Répertoire & "\" & "Parcours")
If Dir(Répertoire & "\Parcours" & "\" & Lieu, 16) = "" Then MkDir (Répertoire & "\" & "Parcours" & "\" & Lieu)
'Détermination du nom du fichier
Fichier = "Parcours N°" & Parcours & ".jpg"
'Détermination du chemin du fichier avec son nom
ChemFichier = Répertoire & "\Parcours" & "\" & Lieu & "\" & Fichier
'**** Partie permettant de créer l'image en JPG dans le répertoire ****
'Attribution de l'objet à s
'Set s = ....
'Copie l'image
Image.CopyPicture
'Colle l'objet avec les dimensions d'origine (voir plus bas pour suppression de cette image)
ActiveSheet.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
'Exporte l'image avec le chemin et le nom
ActiveSheet.ChartObjects(1).Chart.Export Filename:=ChemFichier
'Supprime l'objet créé plus haut, en testant tous les objets, avec 2007 qq problèmes d'image
For Each x In ActiveSheet.Shapes
If x.Type = 3 And (Left(x.Name, 5) = "Chart" Or Left(x.Name, 5) = "Graph") Then x.Delete
Next x
'**** Partie permettant de copier l'image JPG dans la Feuil4 ****
'Attribution d'une valeur à la variable Col, détermine dans
'quelle colonne on va copier l'image dans la Feuil4
Col = IIf(Lieu = "Robin", 2, 2)
'Recherche la ligne de copie (!!!! ça serait plus simple si les cellules n'étaient pas fusionnées !!!)
Lig = Application.Match(Parcours2, Feuil4.Columns(1), 0)
'Détermination du nom de l'image
Image = Lieu & " " & Fichier
'Avec la Feuil4
With Feuil4
'Vérifie si l'image existe dans Feuil4
For Each x In .Shapes
'Si elle existe
If x.Name = Image Then
'On demande si l'on souhaite la supprimer ?
If MsgBox("Voulez-vous remplacer l'image ?", vbYesNo, "Remplacement") = vbYes Then
'si réponse OUI, on supprime l'image puis on sort de la boucle
.Shapes(Image).Delete
'On sort de la boucle pour suivre
Exit For
'Si la réponse est NON
Else
'On sort da la macro puisque l'on ne veut pas la remplacer.
Exit Sub
End If
End If
'On continue avec l'image suivante
Next x
'Détermination de c pour définir où copier
Set c = .Cells(Lig, Col)
'Insertion du fichier avec renommage de l'image dans la Feuil4
.Pictures.Insert(ChemFichier).Name = Image
'Modifie la hauteur de l'image, rajouter *2 :égale à 2 fois la hauteur de la cellule, car cellule fusionnée
.Shapes(Image).Height = c.Height * 0.9 'image à 90%
'Positionne à partir de la gauche l'image par rapport à la cellule C.Left Ici centrer:
.Shapes(Image).Left = c.Left + (c.Width * 0.05)
'Idem pour le positionnement en hauteur C.Top; Ici centrer:
.Shapes(Image).Top = c.Top + (c.Height * 0.05)
'Permet de garder les propotions de l'image, puisque ci-dessus nous n'avons modifié que la hauteur
.Shapes(Image).LockAspectRatio = msoTrue
End With
End Sub
Je te joint au cas ou mon fichier excel en espérant que la taille passe
Merci d'avance
Loïc
) la copie de l'image en JPG dans le répertoire.
