Effacer des plusieurs photos sur une feuille
Bonjour / Bonsoir,
Je reviens a nouveau vers vous car j'ai un soucis que j'ai du mal a comprendre.
Petite explication
J'insère des photos sur une feuille a l'aide d'une macro. J'ai 4 emplacement de photos (Étiquette, Conditionnement, Aspect, Nom Commercial). L'utilisateur choisie a l'aide d'un userform ou il veut insérer sa photo et cela l'ajoute automatiquement en la redimensionnant a la taille de plusieurs cellules fusionne (ex: [A49:D72], [E49:H72], [A73:D96] et [E73:H96]). Jusque la tout va bien ca marche!
La ou je bloque, c'est que j'aimerais avant chaque ajout d'une nouvelle photo, effacer celle déjà en place, ça fonctionne sur mes deux premiers emplacement, mais pas sur les deux derniers et je ne sais pas pourquoi.
Je vous met le code en entier afin de voir plus clair:
' ---
' IMPORTATION DES IMAGES
' ---
'
'
Private Sub CommandButton_insertion_Click()
Dim iPict As IPictureDisp
Dim Hauteur As String, Largeur As String, EmplacementPhoto As String, PG As String, CheminDossier As String
Dim L As Single, T As Single, W As Single, H As Single
Dim img As Shape, Sh As Shape
' ---
' CHOIX DE L'EMPLACEMENT
' ---
For Each bouton_emplacement In Frame_Emplacement.Controls 'Pour chaque bouton de la frame
If bouton_emplacement.Value Then 'Si un bouton est coché alors
EmplacementPhoto = bouton_emplacement.Caption 'L'emplacement de la photo corresponds au bouton sélectionné
End If
Next
PG = Range("D4").Value 'Stockage du PG contenu dans la feuille en cellule D4 dans la variable PG
CheminDossier = ActiveWorkbook.Path & "\Photos\" & PG 'Stock le chemin d'accès du dossiers PHOTOS\PG
' ---
' PERMET D'OUVRIR SUR LE DOSSIER DE LA MP (EN FONCTION DU PG)
' ---
ChDrive "M:" '---
ChDir CheminDossier ' Permet d'ouvrir l'arborenscence directement dans le dossiers concerné par le PG
Image = Application.GetOpenFilename
' ---
' PERMET DE CONNAITRE LA TAILLE DE LA PHOTO POUR DETERMINER SON POSITIONNEMENT
' ---
On Error GoTo Fin
Set iPict = LoadPicture(Image)
Hauteur = Round((iPict.Height) / 21.16, 0) 'Permet de stocké la hauteur de l'image en pixel
Largeur = Round((iPict.Width) / 21.16, 0) 'Permet de stocké la largeur de l'image en pixel
If Image <> False Then 'Si on charge une image alors
a = Split(Image, "\")
monimage = a(UBound(a))
' ---
' PERMET D'EFFACER LA PHOTO EXISTANTE AVANT D'INSERER LA NOUVELLE
' ---
If EmplacementPhoto = "Etiquette" Then 'Si on choisie l'emplacement ETIQUETTE
For Each Sh In Worksheets("Creation_FVP").Shapes 'On regarde si il existe déjà une photo a cette emplacement
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("A49").Address Then 'Si oui alors
Sh.Delete 'On efface la photo
End If
Next
' ---
' INSERE LA PHOTO EN FONCTION DE SA TAILLE
' ---
Set C = Range("A49:D72") 'On selectionne ou ajouter la photo sur la feuille
If Largeur > Hauteur Then 'Si la largeur est plus grande que la hauteur alors
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Width = C.Width
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top + (C.Height - .Shapes(monimage).Height) / 2
.Shapes(monimage).LockAspectRatio = msoTrue
End With
Else 'Sinon
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Height = C.Height
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top
.Shapes(monimage).Width = C.Width
.Shapes(monimage).LockAspectRatio = msoTrue
End With
End If
ElseIf EmplacementPhoto = "Conditionnement" Then
For Each Sh In Worksheets("Creation_FVP").Shapes
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("E49").Address Then
Sh.Delete
End If
Next
Set C = Range("E49:H72")
If Largeur > Hauteur Then
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Width = C.Width
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top + (C.Height - .Shapes(monimage).Height) / 2
.Shapes(monimage).LockAspectRatio = msoTrue
End With
Else
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Height = C.Height
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top
.Shapes(monimage).Width = C.Width
.Shapes(monimage).LockAspectRatio = msoTrue
End With
End If
ElseIf EmplacementPhoto = "Aspect" Then
For Each Sh In Worksheets("Creation_FVP").Shapes
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("A73").Address Then
Sh.Delete
End If
Next
Set C = Range("A73:D96")
If Largeur > Hauteur Then
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Width = C.Width
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top + (C.Height - .Shapes(monimage).Height) / 2
.Shapes(monimage).LockAspectRatio = msoTrue
End With
Else
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Height = C.Height
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top
.Shapes(monimage).Width = C.Width
.Shapes(monimage).LockAspectRatio = msoTrue
End With
End If
ElseIf EmplacementPhoto = "Nom Commercial" Then
For Each Sh In Worksheets("Creation_FVP").Shapes
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("E73").Address Then
Sh.Delete
End If
Next
Set C = Range("E73:H96")
If Largeur > Hauteur Then
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Width = C.Width
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top + (C.Height - .Shapes(monimage).Height) / 2
.Shapes(monimage).LockAspectRatio = msoTrue
End With
Else
With ActiveSheet
.Pictures.Insert(Image).Name = monimage
.Shapes(monimage).Height = C.Height
.Shapes(monimage).Left = C.Left
.Shapes(monimage).Top = C.Top
.Shapes(monimage).Width = C.Width
.Shapes(monimage).LockAspectRatio = msoTrue
End With
End If
End If
End If
Set iPict = Nothing
Fin:
End SubComme vous pouvez le voir dans le code, j'utilise le code ci dessous afin d'effacer une photo si elle existe dans l'emplacement "A49":
For Each Sh In Worksheets("Creation_FVP").Shapes 'On regarde si il existe déjà une photo a cette emplacement
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("A49").Address Then 'Si oui alors
Sh.Delete 'On efface la photo
End If
NextJ'utilise exactement le même pour mes 4 emplacements, mais cela n'efface pas les photos présentes en "A73" et "E73"!
Pouvez vous m'aider ?
Merci d'avance,
Cordialement,
Fonbs
Bonjour
Sans fichier ce n'est pas évident
Vérifies exactement la position de chaque photo
Rajoute dans chaque partie de suppression de la photo les lignes surlignées
For Each Sh In Worksheets("Creation_FVP").Shapes 'On regarde si il existe déjà une photo a cette emplacement
MsgBox "Coin supérieur gauche : " & Sh.TopLeftCell.Address
'ou/et
Debug.Print "Coin supérieur gauche : " & Sh.TopLeftCell.Address
If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("A49").Address Then 'Si oui alors
Sh.Delete 'On efface la photo
End If
NextBonjour,
Désolé de ce silence durant les deux derniers jours, mais je n'ai pas accès a internet au travail, ce qui ne me facilite pas la tache
Banzai64 a écrit :Bonjour
Sans fichier ce n'est pas évident
Vérifies exactement la position de chaque photo
Rajoute dans chaque partie de suppression de la photo les lignes surlignées
For Each Sh In Worksheets("Creation_FVP").Shapes 'On regarde si il existe déjà une photo a cette emplacement MsgBox "Coin supérieur gauche : " & Sh.TopLeftCell.Address 'ou/et Debug.Print "Coin supérieur gauche : " & Sh.TopLeftCell.Address If Sh.TopLeftCell.Address = Sheets("Creation_FVP").Range("A49").Address Then 'Si oui alors Sh.Delete 'On efface la photo End If Next
J'ai essayer votre code, mais cela ne fonctionne pas, du coup j'ai fais le ménage dans une copie du fichier (pour des raisons de confidentialité de mon travail) et je vous envoi le fichier avec le nécessaire pour mon problème.
Sur le fichier, il y a 2 feuille, une nommé Liste_MP qui me sert en temps normal de BDD afin de remplir la deuxième feuille nommé Creation_FVP.
Sur le feuille Creation_FVP, un bouton macro permettant d'ajouter des photos dans les 4 emplacements prévu a cette effet. Jusque la tout fonctionne.
Mais j'aimerais lors de la fermeture du fichier effacer les photos si il y en a de présente, et c'est la que mon code ne fonctionne pas.
En espérant que vous pourrez m'aider !
Merci d'avance,
Fonbs
Bonjour
Le problème vient que tu n'as pas des tailles identiques pour tes photos
Donc pour certaines photos (le coin supérieur gauche) n'est pas à l'emplacement prévu, d’où le non effaçage de cette 'image
Une solution, c'est de copier dans une feuille (dans des colonnes masquées) cet emplacement et de les effacer lors de l'insertion d'une autre image
C'est une idée comme cela (je n'ai pas testée)
A toi de dire si cela peut te convenir (de préciser ou stocker ces valeurs - il faut 4 cellules)
A suivre
Banzai64 a écrit :Bonjour
Le problème vient que tu n'as pas des tailles identiques pour tes photos
Donc pour certaines photos (le coin supérieur gauche) n'est pas à l'emplacement prévu, d’où le non effaçage de cette 'image
Une solution, c'est de copier dans une feuille (dans des colonnes masquées) cet emplacement et de les effacer lors de l'insertion d'une autre image
C'est une idée comme cela (je n'ai pas testée)
A toi de dire si cela peut te convenir (de préciser ou stocker ces valeurs - il faut 4 cellules)
A suivre
Bonjour,
Oui cela peut m’intéresser, comment dois je procéder ? (je débute en vba et je m'aide surtout de tuto et code trouver sur le net que j'adapte a ma sauce ;p)
Bonjour,
Je vienssuis de résoudre mon problème autrement ! J'ai simplement enlever dans mon code la partie qui centrait la photo (format paysage) dans ma cellule fusionner. Du coup à l'insertion elle se met bien dans le coin supérieur gauche, du coup mon code pour l'effacer fonctionne!
Merci Encore Banzai64, c'est ton intervention qui m'à fait comprendre pourquoi ça ne marchais pas et comment le résoudre!
Bonne journée à vous
Fonbs