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

[Emile63]

Bonjour à tous,

Ajoutant fréquemment des images dans les Notes des cellules (Anciennement les commentaires) j'aimerais automatiser la procédure un peu fastidieuse avec du code VBA, mais je ne vois pas comment le faire...
Si quelqu'un à une suggestion, je suis preneur. :-)
Voici un peu le schéma auquel je pense : ---------------------------------
Sub Ajouter image ()
'Insertion d'un commentaire / note a partir de la cellule active.

ActiveCell.AddComment
With ActiveCell.Comment
.Visible = False
.Text Text:=""
' ????
MonCheminImage InputBox
End With

With Selection
.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
End with

End Sub

Je vous remercie d'avance pour votre aide,
Bonne journée

Emile

[MichD]

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

[Emile63]

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

[MichD]

Le 09/09/21 à 02:07, 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

[Emile63]

> 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

[MichD]

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

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

[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
'------------------------------------------

[Emile63]

Bonjour MichD

C'est Top, Merci !

Très bon week-end,
Emile

[MichD]

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

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

[Emile63]

Merci pour la précision :-)

[Emile63]

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

[MichD]

Essaie comme ceci :

J'ai fixé les bornes de la largeur de l'image entre
3 et 8 cm. Tu peux les modifier à volonté.

Si tu prends une règle, tu devrais obtenir la largeur de l'image demandée.

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

Dim T As Double, X As Double, L As Variant

'Chemin du répertoire contenant les images

CheminEtTypeFichier = "F:\OneDrive\Images\Pellicule\*.*"

Fichier = BrowseFile(CheminEtTypeFichier)
If Fichier <> "" Then

L = CDbl(InputBox("Vous allez insérer une image dans un commentaire." & _
vbCrLf & "Quelle doit être la largeur de cette image en " & _
vbCrLf & "centimètre. Saisissez la largeur désirée, entre 3 et 8
centimètres." & _
"Exemple : 4 ou 5 ou 4.5, etc.", "Largeur de l'image", "5"))

'Détermine les bornes de l'image entre 3 et 8cm
'à toi de choisir les bornes désirées
If L < 3 Or L > 8 Then
MsgBox "La valeur saisie pour la largeur de l'image " & _
"est en dehors des bornes permises, entre 3 et 8. " & _
"Exécuter à nouveau la procédure. ", vbCritical + vbOKOnly, _
"Largeur de l'image non permise"
Exit Sub
End If

With ActiveCell
.ClearComments
.AddComment
With .Comment

.Visible = True 'or false

.Text Text:=""
.Shape.Fill.UserPicture Fichier
.Shape.LockAspectRatio = msoTrue

.Shape.Width = 103 * L / 4

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 multisé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éfinis une liste de filtres pour le champ "Type de fichiers".
'tu peux ajouter toutes les extensions que tu as besoin

[MichD]

Le 13/09/21 à 10:30, MichD a écrit :

Dans la procédure "Sub Insérer_Image_ActiveCell()" remplace

.Shape.Width = 108.78 * L / 4

Par

.Shape.Width = 108.78 * L / 4

MichD

[MichD]

Le 13/09/21 à 12:40, MichD a écrit :

En fait, le résultat est vrai, si ton moniteur à 24" et qu'il est en HD
1920 X1080.
Selon la grandeur d'écran, le mode d'affichage (1920 X 1080), le nombre
de points à l'écran du moniteur varie. Dans mon environnement, l'image a
vraiment le nombre de CM désiré que tu peux mesurer avec une règle.

Regarde à cette adresse, tu verras différentes manières d'effectuer des
conversions dans Excel, de centimètres en points, de pouces en points,
points en pixels.

La valeur 108.78 est estimée et ne provient pas de la fonction :
x=application.CentimetersToPoints(B), B étant le nombre de CM

https://exceloffthegrid.com/vba-convert-centimeters-inches-pixels-to-points/

Pour obtenir un vrai 5 CM à l'écran (que tu peux mesurer avec une règle)
compte tenu des différentes variables énoncées, la donne est un peu plus
complexe que celle énoncée ici.

La solution énoncée ici ne convient pas à tous les environnements.

MichD

[Emile63]

----------------------------------
Bonjour MichD,

J'ai toujours le problème d'une image non proportionnelle, je t'ai mis un exemple en document joint.
https://www.cjoint.com/c/KIopKcx14kk

Le cadre de l'image mesure bien la taille donnée (5 cm par ex.), mais l'image en question en souffre :(
Est-ce qu'avec du code on arrive à géré la boîte de message figurant sur le fichier ci-joint?
Par ailleurs, c'est entre 5 et 15 cm de largeur que je souhaiterais visualiser...
J'avoue ne pas (encore) avoir été au lien que tu me suggères (manque de temps aujourd'hui),
mais ton commentaire : x=application.CentimetersToPoints(B)
me paraît pile poil ce que je cherche à utiliser pour autant que soit résolue cette satanée proportionnalité de l'image :-)

Merci encore pour tes suggestion, et très bonne fin de journée.

Emile

[MichD]

Le 14/09/21 à 11:46, Emile63 a écrit :

La procédure est basée sur la largeur du commentaire.
Cependant, tu devrais avoir des images proportionnées
aux originaux.

Une dernière version :
fichier joint : https://www.cjoint.com/c/KIos6T2m6sF

'---------------------------------------------

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

Dim A As Double, B As Double, C As Double, L As Double

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

Fichier = BrowseFile(CheminEtTypeFichier)

If Fichier <> "" Then
L = CDbl(InputBox("Vous allez insérer une image dans un
commentaire." & _
vbCrLf & "Quelle doit être la largeur de cette image en " & _
vbCrLf & "centimètre. Saisissez la largeur désirée, entre 3 et
8 centimètres." & _
"Exemple : 4 ou 5 ou 4.5, etc.", "Largeur de l'image", "5"))

'Détermine les bornes de l'image entre 3 et 8cm
'à toi de choisir les bornes désirées
If L < 3 Or L > 8 Then
MsgBox "La valeur saisie pour la largeur de l'image " & _
"est en dehors des bornes permises, entre 3 et 8. " & _
"Exécuter à nouveau la procédure. ", vbCritical + vbOKOnly, _
"Largeur de l'image non permise"
Exit Sub
End If

'Insérer un fichier image dans Excel
Set Sh = Feuil2.Shapes.AddPicture(Fichier, False, True,
Range("B2").Left, Range("B2").Top, -1, -1)
A = Sh.Width
B = Application.CentimetersToPoints(L)
If A > B Then
C = B / A
Sh.ScaleWidth C, msoFalse, msoScaleFromTopLeft
Else
C = B / A
Sh.ScaleHeight C, msoFalse, msoScaleFromTopLeft

End If

With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""
.Shape.Fill.UserPicture Fichier

.Shape.Width = Sh.Width
.Shape.Height = Sh.Height
Sh.Delete

End With
End With
Else

MsgBox "Aucune image a été retenue.", _
vbInformation + vbOKCancel, "Opération annulée."
End If

End Sub
'---------------------------------------------

'---------------------------------------------

MichD

[Emile63]

Bonjour MichD,

Merci pour cette procédure et feuille avec le l'insertion.

La ligne que tu as créee dans cette dernière mouture:
' Set Sh = Feuil2.Shapes.AddPicture(Fichier, False, True, Range("B2").Left, Range("B2").Top, -1, -1)

Cherche la cellule B2 de la feuil2, mon problème c'est que je souhaite insérer l'image dans n'importe quelle feuille de n'importe quel classeur.
Je n'ai pas (encore) tester mais est-ce que je suis dans le vrai avec ça ?
Activesheet.Shapes.AddPicture(Fichier, False, True, Range(Activecell).Left, Range(Activecell).Top, -1, -1)

[MichD]

Le 15/09/21 à 05:56, Emile63 a écrit :

Remplace Feuil2 par activesheet c'est OK.
Le code que je donne, ce n'est qu'un exemple. Il ne faut pas te gêner
pour effectuer quelques modifications selon ton environnement.

MichD

[Emile63]

> >
> Remplace Feuil2 par activesheet c'est OK.
> Le code que je donne, ce n'est qu'un exemple. Il ne faut pas te gêner
> pour effectuer quelques modifications selon ton environnement.
>
> MichD

Re-Bonjour MichD,

Merci pour ton aide et ta patience, certainement à bout touchant, mais je n'y arrive pas...
J'ai passé la procédure dans ma feuil PERSONAL.XLSB , pour l'avoir constamment sous la main.
et autant sur l'exemple que tu m'as joint, ça fonctionne, autant depuis n'importe quel endroit de n'importe quelle feuil, je me retrouve avec le même problème de proportions.

J'ai cherché si je trouvais la différence entre l'une et l'autre mais je ne vois pas..

A partir d'ici;
'Tu insert un fichier image dans Excel, OK
Set Sh = ActiveSheet.Shapes.AddPicture(Fichier, False, True, ActiveCell.Left, ActiveCell.Top, -1, -1)

A = Sh.Width
B = Application.CentimetersToPoints(L)

' Tu cherches a connaitre le rapport larg. x hauteur, Ok

If A > B Then
C = B / A
Sh.ScaleWidth C, msoFalse, msoScaleFromTopLeft
Else
C = B / A
Sh.ScaleHeight C, msoFalse, msoScaleFromTopLeft
End If

' Mais la fin de la proc reste inchangée, à sers l'étape préalable de l'image dans la feuille ?
' tu inserts l'image avec les variables A & B du début et donc je ne vois pas à quoi sert la variable C que tu as calculé

With ActiveCell
.ClearComments
.AddComment
With .Comment
.Visible = True 'or false
.Text Text:=""

.Shape.Fill.UserPicture Fichier ' Ici ne devrais tu pas insérer l'image qui est sur la feuille ?
.Shape.Width = A ' ici ce sont les largeur et hauteurs originales te donc ne tien spas compte du rapport de l'image
.Shape.Height = B

[MichD]

Le 15/09/21 à 07:47, Emile63 a écrit :

Chaque fois que tu ajoutes un commentaire, la dimension de celui-ci est
standard. L'image s'adapte au commentaire.
En insérant l'image dans la feuille de calcul, il est possible de
déterminer la dimension de l'image.
Immédiatement après l'insertion de l'image dans la feuille, j'obtiens
avec cette ligne de code, la largeur originale de l'image
A = Sh.Width

L'Image est par la suite redimensionnée selon la largeur choisit pas
l'usager.

Dans le commentaire, l'image n'est pas aux dimensions originales, mais
aux nouvelles dimensions de celle-ci. L'image insérée dans la feuille
est supprimée. Chez moi, cela fonctionne très bien.

Tu peux exécuter la procédure pas à pas en utilisant la touche F8 et
observer la transformation de l'image originale...

Dans un fichier zip, insère quelques images qui te posent problème.

Ce n'est pas sûr que je peux regarder cela aujourd'hui...

MichD

[Emile63]

Le Wednesday, September 15, 2021 à 2:27:01 PM UTC+2, MichD a écrit :
> Le 15/09/21 à 07:47, Emile63 a écrit :
> >

> Chaque fois que tu ajoutes un commentaire, la dimension de celui-ci est
> standard. L'image s'adapte au commentaire.
> En insérant l'image dans la feuille de calcul, il est possible de
> déterminer la dimension de l'image.
> Immédiatement après l'insertion de l'image dans la feuille, j'obtiens
> avec cette ligne de code, la largeur originale de l'image
> A = Sh.Width
>
> L'Image est par la suite redimensionnée selon la largeur choisit pas
> l'usager.
>
> Dans le commentaire, l'image n'est pas aux dimensions originales, mais
> aux nouvelles dimensions de celle-ci. L'image insérée dans la feuille
> est supprimée. Chez moi, cela fonctionne très bien.
>
> Tu peux exécuter la procédure pas à pas en utilisant la touche F8 et
> observer la transformation de l'image originale...
>
> Dans un fichier zip, insère quelques images qui te posent problème.
>
> Ce n'est pas sûr que je peux regarder cela aujourd'hui...
>
> MichD

Ok, prends ton temps.
Merci pour ta disponibilité, et bonne fin de journée.

https://www.cjoint.com/c/KIpnB1wcFtk

[MichD]

Le 15/09/21 à 09:29, Emile63 a écrit :

J'ai pris quelques instants pour faire un test avec l'une de tes images
(doigts) et voici le résultat illustré dans un fichier :
https://www.cjoint.com/c/KIprTkVB8RF

MichD

[Emile63]

Bonjour MichD,

Merci beaucoup pour ton aide, cette fois, les proportions semblent bonnes :-)
Je te souhaite un très bon week-end,

Emile