VBA: Procédure pour ajouter une image dans une note

Le 08/09/21 Í  09:58, Emile63 a écrit :

.ShapeRange.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
' élargir l'image a une largeur de 5 cm avec la hauteur proportionnelle

Bonjour,

Essaie comme ceci :

'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
' élargir l'image a une largeur de 5 cm avec la hauteu
' proportionnelle
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Le Wednesday, September 8, 2021 Í  4:35:22 PM UTC+2, MichD a écrit :

Le 08/09/21 Í  09:58, Emile63 a écrit :
> .ShapeRange.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
> .ShapeRange.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
> ' élargir l'image a une largeur de 5 cm avec la hauteur proportionnelle
Bonjour,

Essaie comme ceci :

'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
' élargir l'image a une largeur de 5 cm avec la hauteu
' proportionnelle
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Bonjour MichD,

Merci pour cette procédure, c'est bien ce que je cherchais. :)
Par rapport Í  l'image insérée, comment puis-je l'affiner:
Je souhaite qu'elle fasse 5 cm de large, et garde la proportionnalité de la hauteur, pour ne pas qu'elle soit difforme, (Respectivement: verrouiller le proportions de la hauteur dans la boÍ®te de dialogue)

Encore merci pour ton aide, et très bonne journée.
Emile

Le 09/09/21 Í  02:07, Emile63 a écrit :

Le Wednesday, September 8, 2021 Í  4:35:22 PM UTC+2, MichD a écrit :

Le 08/09/21 Í  09:58, Emile63 a écrit :

.ShapeRange.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
' élargir l'image a une largeur de 5 cm avec la hauteur proportionnelle

Bonjour,

Essaie comme ceci :

'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.ScaleWidth 1.85, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 2.78, msoFalse, msoScaleFromTopLeft
' élargir l'image a une largeur de 5 cm avec la hauteu
' proportionnelle
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Bonjour MichD,

Merci pour cette procédure, c'est bien ce que je cherchais. :)
Par rapport Í  l'image insérée, comment puis-je l'affiner:
Je souhaite qu'elle fasse 5 cm de large, et garde la proportionnalité de la hauteur, pour ne pas qu'elle soit difforme, (Respectivement: verrouiller le proportions de la hauteur dans la boÍ®te de dialogue)

Encore merci pour ton aide, et très bonne journée.
Emile

Et ceci :

'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
'1 cm = 28.35 points
.Shape.Width = 28.35 * 5
.Shape.Height = 28.35 * 5
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

>
Et ceci :
'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
'1 cm = 28.35 points
.Shape.Width = 28.35 * 5
.Shape.Height = 28.35 * 5
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------

MichD

Bonsoir MichD,

Encore merci pour ton aide !

Malheureusement, les photos apparaissent écrasées. :-(
Il faut que je précise qu'elles ne sont pas carrées mais rectangulaires et toutes de différentes dimensions aussi bien en portrait qu'en paysage.

Je crois que le " .Shape.LockAspectRatio = msoTrue" agit au niveau de :
Format de commentaires -> Onglet: Dimension: Check "Conserver le rapport hauteur / largeur." Ce qui est Ok!

Mais en revanche, dans la même Bte de dialogue, l'onglet: Couleurs et traits > Déroulant: Couleurs > Effets de remplissage : le Check "Verrouiller les proportions de l'image" est désactivé, je pense que c'est cette commande qui manque pour garder les proportions.
Mais je ne sais pas comment le faire... :(

Par ailleurs je voudrais poser la question suivante:
S'il devrait garder le ratio de l'image et les proportions, est-on obligé de préciser la largeur ET la hauteur:
.Shape.Width = 28.35 * 5
.Shape.Height = 28.35 * 5
L'une des deux ne devrait--elle pas suffire ?

Merci pour ta sollicitude et bonne soirée.
Emile

Le 09/09/21 Í  15:14, Emile63 a écrit :

Et ceci :
'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
'1 cm = 28.35 points
.Shape.Width = 28.35 * 5
.Shape.Height = 28.35 * 5
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------

MichD

Bonsoir MichD,

Encore merci pour ton aide !

Malheureusement, les photos apparaissent écrasées. :-(
Il faut que je précise qu'elles ne sont pas carrées mais rectangulaires et toutes de différentes dimensions aussi bien en portrait qu'en paysage.

Je crois que le " .Shape.LockAspectRatio = msoTrue" agit au niveau de :
Format de commentaires -> Onglet: Dimension: Check "Conserver le rapport hauteur / largeur." Ce qui est Ok!

Mais en revanche, dans la même Bte de dialogue, l'onglet: Couleurs et traits > Déroulant: Couleurs > Effets de remplissage : le Check "Verrouiller les proportions de l'image" est désactivé, je pense que c'est cette commande qui manque pour garder les proportions.
Mais je ne sais pas comment le faire... :(

Par ailleurs je voudrais poser la question suivante:
S'il devrait garder le ratio de l'image et les proportions, est-on obligé de préciser la largeur ET la hauteur:
.Shape.Width = 28.35 * 5
.Shape.Height = 28.35 * 5
L'une des deux ne devrait--elle pas suffire ?

Merci pour ta sollicitude et bonne soirée.
Emile

OK, j'ai mal interprété cette ligne dans ta demande :
Je souhaite qu'elle fasse 5 cm de large, et garde la proportionnalité de
la hauteur

Je regarde cela un peu plus tard.

MichD

Essaie ceci :

Les images ont 5 cm comme largeur.

'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String
Dim T As Double, X As Double

'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = False 'or true
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
X = .Shape.Width / 141.75
If X < 1 Then
T = .Shape.Width * (1 + (1 - X)) / 100
ElseIf X > 1 Then
.Shape.Width = .Shape.Width * X
End If
.Shape.ScaleHeight T, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth T, msoFalse, msoScaleFromTopLeft
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Le Friday, September 10, 2021 Í  12:10:28 AM UTC+2, MichD a écrit :

Essaie ceci :

Les images ont 5 cm comme largeur.
'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String
Dim T As Double, X As Double
'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = False 'or true
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
X = .Shape.Width / 141.75
If X < 1 Then
T = .Shape.Width * (1 + (1 - X)) / 100
ElseIf X > 1 Then
.Shape.Width = .Shape.Width * X
End If
.Shape.ScaleHeight T, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth T, msoFalse, msoScaleFromTopLeft
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Bonjour MichD

C'est Top, Merci !

Très bon week-end,
Emile

Le 10/09/21 Í  09:11, Emile63 a écrit :

Le Friday, September 10, 2021 Í  12:10:28 AM UTC+2, MichD a écrit :

Essaie ceci :

Les images ont 5 cm comme largeur.
'------------------------------------------
Sub Insérer_Image_ActiveCell()
Dim CheminEtTypeFichier As String, Fichier As String
Dim T As Double, X As Double
'Chemin du répertoire contenant les images
CheminEtTypeFichier = "F:Images*.*"

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = False 'or true
.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue
X = .Shape.Width / 141.75
If X < 1 Then
T = .Shape.Width * (1 + (1 - X)) / 100
ElseIf X > 1 Then
.Shape.Width = .Shape.Width * X
End If
.Shape.ScaleHeight T, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth T, msoFalse, msoScaleFromTopLeft
End With
End With
Else
MsgBox "Aucune image a été retenue."
End If
End Sub
'------------------------------------------
Function BrowseFile(CheminEtTypeFichier) As String
With Application.FileDialog(msoFileDialogFilePicker)
'Définit un titre pour la boÍ®te de dialogue
.Title = "Choisir le fichier image de ton choix"
'Empêcher la multi-sélection
.AllowMultiSelect = False
'Répertoire par défaut suivi du type de fichier par défaut
.InitialFileName = CheminEtTypeFichier
'Efface les filtres existants.
.Filters.Clear
'Définit une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extension que tu as besoin
.Filters.Add "Images", "*.png; *.jpg; *.bmp"
'Définit le filtre qui s'affiche par
'défaut dans le champ "Type de fichiers "."
.FilterIndex = 1
'Indique le type d'affichage dans la boͮte de dialogue
'(exemple visualisation des propriétés)
.InitialView = msoFileDialogViewProperties
'Affiche la boͮte de dialogue
.Show
If .SelectedItems.Count > 0 Then
BrowseFile = .SelectedItems(1)
Else
BrowseFile = ""
End If
End With
End Function
'-------------------------------------------

MichD

Bonjour MichD

C'est Top, Merci !

Très bon week-end,
Emile

Tu devrais enlever ces 2 lignes de code, elles n’ont aucune utilité en
plus d'être erronées, un oubli de ma part.

ElseIf X > 1 Then
.Shape.Width = .Shape.Width * X

MichD

Le Friday, September 10, 2021 Í  3:27:42 PM UTC+2, MichD a écrit :

Le 10/09/21 Í  09:11, Emile63 a écrit :
> Le Friday, September 10, 2021 Í  12:10:28 AM UTC+2, MichD a écrit :
>> Essaie ceci :
>>
>> Les images ont 5 cm comme largeur.
>> '------------------------------------------
>> Sub Insérer_Image_ActiveCell()
>> Dim CheminEtTypeFichier As String, Fichier As String
>> Dim T As Double, X As Double
>> 'Chemin du répertoire contenant les images
>> CheminEtTypeFichier = "F:Images*.*"
>>
>> Fichier = BrowseFile(CheminEtTypeFichier)
>>
>> If Fichier <> "" Then
>> With ActiveCell
>> .ClearComments
>> .AddComment
>> With .Comment
>> .Visible = False 'or true
>> .Text Text:=""
>> .Shape.Fill.UserPicture Fichier
>> .Shape.LockAspectRatio = msoTrue
>> X = .Shape.Width / 141.75
>> If X < 1 Then
>> T = .Shape.Width * (1 + (1 - X)) / 100
>> ElseIf X > 1 Then
>> .Shape.Width = .Shape.Width * X
>> End If
>> .Shape.ScaleHeight T, msoFalse, msoScaleFromTopLeft
>> .Shape.ScaleWidth T, msoFalse, msoScaleFromTopLeft
>> End With
>> End With
>> Else
>> MsgBox "Aucune image a été retenue."
>> End If
>> End Sub
>> '------------------------------------------
>> Function BrowseFile(CheminEtTypeFichier) As String
>> With Application.FileDialog(msoFileDialogFilePicker)
>> 'Définit un titre pour la boÍ®te de dialogue
>> .Title = "Choisir le fichier image de ton choix"
>> 'Empêcher la multi-sélection
>> .AllowMultiSelect = False
>> 'Répertoire par défaut suivi du type de fichier par défaut
>> .InitialFileName = CheminEtTypeFichier
>> 'Efface les filtres existants.
>> .Filters.Clear
>> 'Définit une liste de filtres pour le champ "Type de fichiers".
>> 'tu peux ajouter toutes les extension que tu as besoin
>> .Filters.Add "Images", "*.png; *.jpg; *.bmp"
>> 'Définit le filtre qui s'affiche par
>> 'défaut dans le champ "Type de fichiers "."
>> .FilterIndex = 1
>> 'Indique le type d'affichage dans la boͮte de dialogue
>> '(exemple visualisation des propriétés)
>> .InitialView = msoFileDialogViewProperties
>> 'Affiche la boͮte de dialogue
>> .Show
>> If .SelectedItems.Count > 0 Then
>> BrowseFile = .SelectedItems(1)
>> Else
>> BrowseFile = ""
>> End If
>> End With
>> End Function
>> '-------------------------------------------
>>
>> MichD
>
> Bonjour MichD
>
> C'est Top, Merci !
>
> Très bon week-end,
> Emile
>
Tu devrais enlever ces 2 lignes de code, elles n’ont aucune utilité en
plus d'être erronées, un oubli de ma part.
ElseIf X > 1 Then
.Shape.Width = .Shape.Width * X
MichD

Merci pour la précision :-)

Le Saturday, September 11, 2021 Í  10:17:20 PM UTC+2, Emile63 a écrit :

Le Friday, September 10, 2021 Í  3:27:42 PM UTC+2, MichD a écrit :
> Le 10/09/21 Í  09:11, Emile63 a écrit :
> > Le Friday, September 10, 2021 Í  12:10:28 AM UTC+2, MichD a écrit :
> >> Essaie ceci :
> >>
> >> Les images ont 5 cm comme largeur.
> >> '------------------------------------------
> >> Sub Insérer_Image_ActiveCell()
> >> Dim CheminEtTypeFichier As String, Fichier As String
> >> Dim T As Double, X As Double
> >> 'Chemin du répertoire contenant les images
> >> CheminEtTypeFichier = "F:Images*.*"
> >>
> >> Fichier = BrowseFile(CheminEtTypeFichier)
> >>
> >> If Fichier <> "" Then
> >> With ActiveCell
> >> .ClearComments
> >> .AddComment
> >> With .Comment
> >> .Visible = False 'or true
> >> .Text Text:=""
> >> .Shape.Fill.UserPicture Fichier
> >> .Shape.LockAspectRatio = msoTrue
> >> X = .Shape.Width / 141.75
> >> If X < 1 Then
> >> T = .Shape.Width * (1 + (1 - X)) / 100
> >> ElseIf X > 1 Then
> >> .Shape.Width = .Shape.Width * X
> >> End If
> >> .Shape.ScaleHeight T, msoFalse, msoScaleFromTopLeft
> >> .Shape.ScaleWidth T, msoFalse, msoScaleFromTopLeft
> >> End With
> >> End With
> >> Else
> >> MsgBox "Aucune image a été retenue."
> >> End If
> >> End Sub
> >> '------------------------------------------
> >> Function BrowseFile(CheminEtTypeFichier) As String
> >> With Application.FileDialog(msoFileDialogFilePicker)
> >> 'Définit un titre pour la boÍ®te de dialogue
> >> .Title = "Choisir le fichier image de ton choix"
> >> 'Empêcher la multi-sélection
> >> .AllowMultiSelect = False
> >> 'Répertoire par défaut suivi du type de fichier par défaut
> >> .InitialFileName = CheminEtTypeFichier
> >> 'Efface les filtres existants.
> >> .Filters.Clear
> >> 'Définit une liste de filtres pour le champ "Type de fichiers".
> >> 'tu peux ajouter toutes les extension que tu as besoin
> >> .Filters.Add "Images", "*.png; *.jpg; *.bmp"
> >> 'Définit le filtre qui s'affiche par
> >> 'défaut dans le champ "Type de fichiers "."
> >> .FilterIndex = 1
> >> 'Indique le type d'affichage dans la boͮte de dialogue
> >> '(exemple visualisation des propriétés)
> >> .InitialView = msoFileDialogViewProperties
> >> 'Affiche la boͮte de dialogue
> >> .Show
> >> If .SelectedItems.Count > 0 Then
> >> BrowseFile = .SelectedItems(1)
> >> Else
> >> BrowseFile = ""
> >> End If
> >> End With
> >> End Function
> >> '-------------------------------------------
> >>
> >> MichD
> >
> > Bonjour MichD
> >
> > C'est Top, Merci !
> >
> > Très bon week-end,
> > Emile
> >
> Tu devrais enlever ces 2 lignes de code, elles n’ont aucune utilité en
> plus d'être erronées, un oubli de ma part.
> ElseIf X > 1 Then
> .Shape.Width = .Shape.Width * X
> MichD
Merci pour la précision :-)

Re-Bonjour MichD,

Sans vouloir abuser,
je me rends compte que 5 cm de large ça ne joue pas toujours dans les feuille,
comment je pourrais faire pour ajouter une inputBox avec 5 (cm) par défaut, mais qui me permette de changer la largeur Í  une autre dimension (toujours en cm) le cas échéant?
Encore merci pour ton aide et ta patience. :)
Cordialement,
Emile