1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
| Sub PhotoEnCommentaire()
Dim répertoirePhotos As String, sExt As String, sFile As String
Dim ech As Integer, c As Range
Dim myShell, myFolder, myFile, Taille
répertoirePhotos = "D:\! Tests" '--- à adapter --- sans \ en fin
sExt = ".png" '--- extension, à adapter
ech = 1 '--- échelle, à adapter
For Each c In Range("A2", [A65000].End(xlUp)) '--- noms en colonne A
c.ClearComments
If Dir(répertoirePhotos & "\" & c & sExt) <> "" Then
c.AddComment
c.Comment.Text Text:=CStr(c.Value)
c.Comment.Visible = True
c.Comment.Shape.Fill.UserPicture répertoirePhotos & "\" & c.Value & sExt
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(répertoirePhotos & "\")
Set myFile = myFolder.Items.Item(c & sExt)
Taille = myFolder.GetDetailsOf(myFile, 31) '--- 31
'Debug.Print Taille
Taille = Mid(Taille, 2)
With c.Comment.Shape
.Height = Val(Split(Taille, "x")(1))
.Width = Val(Split(Taille, "x")(0))
.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
'Debug.Print c.Value, Taille, .Height, .Width ', .ScaleHeight, .ScaleWidth
End With
c.Comment.Visible = False
Else
MsgBox "Image non trouvée: " & c, , " Pour info"
End If
Next c
End Sub |
Partager