Insérer et renommer une image avec une macro.
Bonjour à tous,
Je suis nouveau, je ne sais pas s'il ya un topic de présentation. Donc dites-le moi s'il y a des "formalités" à remplir...
Cela fait déjà quelques temps que je parcoure ce forum à la recherche d'informations sur les macros. Il y a 5 jours, je n'imaginais même pas que ça puisse éxister, et c'est dans le cadre d'un travail à faire que j'ai dû m'y mettre. Mes connaisssances sont donc proches de zéro et donc, pour parvenir à mes fins, j'ai procédé par imitation des matrices que j'ai pu rencontrer et trouver. Cependant, je suis bel et bien bloqué pour de bon.
Je vous expose mon problème : j'aimerai pouvoir insérer dans une cellule, une image et la renommer en même temps par l'intermédiaire d'une boîte de dialogue où l'on pourrait entrer le nom voulu. J'ai déjà réussi à réaliser la partie insertion mais c'est la partie renommage qui me bloque.
J'ai sur une feuille Excel, 8 cadres où je peux insérer et redimensionner de manière automatique les photos que j'insère. Pour contourner le problème, j'ai jusqu'à présent, créer 8 macros, avec le renommage à la fin par défaut : cf avant dernière ligne.
J'ai trouvé des macros pour renommer qqchose par l'intermédiare d'une inputbox mais uniquement pour renommer des feuilles d'un classeur comme sur ce topic : https://www.excel-downloads.com/threads/creer-une-inputbox-pour-renommer-un-onglet.121523/
Mais il faudrait remplacer dans la macro, la feuille par "la sélection" dans mon cas ou par "l'image" dans le code suivant, qui lui sert à renommer des feuilles :
Merci d'avance.
Damien
Bonjour à tous,
Je suis nouveau, je ne sais pas s'il ya un topic de présentation. Donc dites-le moi s'il y a des "formalités" à remplir...
Cela fait déjà quelques temps que je parcoure ce forum à la recherche d'informations sur les macros. Il y a 5 jours, je n'imaginais même pas que ça puisse éxister, et c'est dans le cadre d'un travail à faire que j'ai dû m'y mettre. Mes connaisssances sont donc proches de zéro et donc, pour parvenir à mes fins, j'ai procédé par imitation des matrices que j'ai pu rencontrer et trouver. Cependant, je suis bel et bien bloqué pour de bon.
Je vous expose mon problème : j'aimerai pouvoir insérer dans une cellule, une image et la renommer en même temps par l'intermédiaire d'une boîte de dialogue où l'on pourrait entrer le nom voulu. J'ai déjà réussi à réaliser la partie insertion mais c'est la partie renommage qui me bloque.
J'ai sur une feuille Excel, 8 cadres où je peux insérer et redimensionner de manière automatique les photos que j'insère. Pour contourner le problème, j'ai jusqu'à présent, créer 8 macros, avec le renommage à la fin par défaut : cf avant dernière ligne.
Code:
Sub insere_image_ratio_1q()
Dim ficimg As String, Ad As String
Dim MemW As Long, MemH As Long, T As Integer, L As Integer
Dim Lg As Integer, HT As Integer, RatioCell As Single
Dim CellH As Long, CellW As Long, RatioHz As Single, RatioVt As Single
Ad = Selection.Address
CellH = Selection.Height
CellW = Selection.Width
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
If ficimg = "Faux" Then Exit Sub
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
With Selection.ShapeRange
MemW = .Width: MemH = .Height
'adapte les ratio
If MemH < CellH And MemW < CellW Then
'l'image < cellule
RatioHz = MemH / CellH
RatioVt = MemW / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (CellW / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW > CellW Then
'l'image > cellule
RatioHz = CellH / MemH
RatioVt = CellW / MemW
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW < CellW Then
'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
ElseIf MemH < CellH And MemW > CellW Then
'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
Else
Stop ' pas prévu ?
End If
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Range(Ad).Top + T ' haut de la cellule
.Left = Range(Ad).Left + L ' gauche de la cellule
.Height = HT
.Width = Lg ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
Selection.Name = "photo1"
End SubJ'ai trouvé des macros pour renommer qqchose par l'intermédiare d'une inputbox mais uniquement pour renommer des feuilles d'un classeur comme sur ce topic : https://www.excel-downloads.com/threads/creer-une-inputbox-pour-renommer-un-onglet.121523/
Mais il faudrait remplacer dans la macro, la feuille par "la sélection" dans mon cas ou par "l'image" dans le code suivant, qui lui sert à renommer des feuilles :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vr As String
Dim pl As Range
Dim r As Range
Dim pa As String
If Target.Address <> "$B$4" Then Exit Sub
If Target.Value = "" Then Exit Sub
Target.Select
vr = Range("B4").Value
Set pl = Sheets("base de donnée").Range("A1").CurrentRegion
Set pl = pl.Offset(1, 0).Resize(pl.Rows.Count - 1, pl.Columns.Count)
pl.Interior.ColorIndex = xlNone
Set r = pl.Find(vr, LookAt:=xlPart)
If Not r Is Nothing Then
pa = r.Address
Do
r.Interior.ColorIndex = 3
Set r = pl.FindNext(r)
Loop While Not r Is Nothing And r.Address <> pa
Sheets("base de donnée").Activate
Else
MsgBox "Valeur non trouvée !"
End If
End SubDamien
Dernière édition:
,
