Public Function dimensionsImage(cheminFichier As Variant, dossier As Variant, Itm As Integer)
Dim objShell As Object, strFileName As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(dossier)
Set strFileName = objFolder.Items.Item(cheminFichier)
dimensionsImage = objFolder.getDetailsOf(strFileName, Itm)
Set objShell = Nothing
Set strFileName = Nothing
Set objFolder = Nothing
End Function
Sub bullimage()
'
'
' Macro mise à jour le 03/03/09 par CVO
Dim fs As Object
ChDir ("G:\_Chemdraw")
cheminFichier = Application.GetOpenFilename(FileFilter:="Fichiers Image (*.jpg;*.gif), *.jpg;*.gif ", Title:="Fichier Image")
'Arrêt de la procédure si on clique sur Annuler
If Trim(cheminFichier) = "Faux" Then Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
dossier = fs.GetParentFolderName(cheminFichier)
ActiveCell.AddComment
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Text Text:=""
ActiveCell.Comment.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
ActiveCell.Comment.Shape.Fill.BackColor.RGB = RGB(255, 255, 255)
ActiveCell.Comment.Shape.Fill.UserPicture (cheminFichier)
ActiveCell.Comment.Shape.LockAspectRatio = msoFalse
ActiveCell.Comment.Shape.Width = Val(dimensionsImage(cheminFichier, dossier, 27))
ActiveCell.Comment.Shape.Height = Val(dimensionsImage(cheminFichier, dossier, 28))
ActiveCell.Hyperlinks.Add anchor:=ActiveCell, Address:=cheminFichier, TextToDisplay:=ActiveCell.Value
ActiveCell.Offset(-1, 0).Copy
ActiveCell.PasteSpecial (xlPasteFormats)
End Sub