Microsoft 365 VBA : intégration photo en commentaire de cellule

[VAEA]

Bonjour,

Je vous contacte car je souhaiterais intégrer automatiquement des photos en commentaire de cellule (text de la cellule = nom de la photo dans le dossier)

J'ai un code qui fonctionne (voir ci dessous)

Sub test_photo()
'
' test_photo Macro
'

'
Dim DossierImages As String, Fichier As String, I As Integer, name As Variant

For I = 1 To 1600
name = Cells(I, 2).Value
DossierImages = "C:\Users\v.h\Desktop\TEST MACRO PHOTO\"
Fichier = name & ".jpg"

With Cells(I, 2)
.ClearComments
.AddComment
.Comment.Text Text:=""
With .Comment
.Shape.Fill.UserPicture DossierImages & Fichier
.Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
.Shape.LockAspectRatio = msoFalse
.Shape.Height = 159.75
.Shape.Width = 120#
End With
End With
Next
End Sub


Cependant, dès qu'une photo n'existe pas dans le dossier (par rapport au text de la cellule) la macro s'arrête et bloque sur la ligne
.Shape.Fill.UserPicture DossierImages & Fichier

J'aurais aimé un critère supplémentaire qui dit que si la photo correspondant à la cellule est n'existe pas dans le dossier alors laisser le commentaire vide ou annotation "photo KO"

Deuxième question, sur la ligne :
For I = 1 To 1600
J'aurais souhaité qu'au lieu de s'arrêter à la ligne 1600, la macro s'arrête lorsqu'il n'y a plus de text dans la cellule.

Merci d'avance à tout le monde,

 

[patricktoulon]

bonjour evite d'utilise name pour une variable

For I = 1 To 1600
nom= Cells(I, 2).Value
DossierImages = "C:\Users\v.h\Desktop\TEST MACRO PHOTO\"
Fichier = nom & ".jpg"
'----------------------------------
if dir(DossierImages &"\" & fichier)<>"" then
'With Cells(I, 2)
.ClearComments
.AddComment
.Comment.Text Text:=""
With .Comment
.Shape.Fill.UserPicture DossierImages & Fichier
.Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
.Shape.LockAspectRatio = msoFalse
.Shape.Height = 159.75
.Shape.Width = 120#
End With
End With
end if
Next
End Sub

 

[patricktoulon]

Bonjour @Jacky67
c'est pas grave
le luxe c'est d'avoir le choix 😉
cela dit un msgbox a chaque raté ça va vite gonfler (qu'en pense tu?)
remplace ton msgbox par .Comment.Text Text:=" PHOTO NON DISPO"
😉

 

[Jacky67]

Bonjour @Jacky67
c'est pas grave
le luxe c'est d'avoir le choix 😉
cela dit un msgbox a chaque raté ça va vite gonfler (qu'en pense tu?)

😉

Ca c'est vvRRRai ca

Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.

Accepter les cookies de tiers

Msgbox supprimé

 

[patricktoulon]

re
hoh purée si la même Denis s'en mêle moi je me sauve 🤪 🤣

 

[Jacky67]

Bonjour,

Je vous contacte car je souhaiterais intégrer automatiquement des photos en commentaire de cellule (text de la cellule = nom de la photo dans le dossier)

J'ai un code qui fonctionne (voir ci dessous)

Sub test_photo()
'
' test_photo Macro
'

'
Dim DossierImages As String, Fichier As String, I As Integer, name As Variant

For I = 1 To 1600
name = Cells(I, 2).Value
DossierImages = "C:\Users\v.h\Desktop\TEST MACRO PHOTO\"
Fichier = name & ".jpg"

With Cells(I, 2)
.ClearComments
.AddComment
.Comment.Text Text:=""
With .Comment
.Shape.Fill.UserPicture DossierImages & Fichier
.Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.Shape.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
.Shape.LockAspectRatio = msoFalse
.Shape.Height = 159.75
.Shape.Width = 120#
End With
End With
Next
End Sub


Cependant, dès qu'une photo n'existe pas dans le dossier (par rapport au text de la cellule) la macro s'arrête et bloque sur la ligne
.Shape.Fill.UserPicture DossierImages & Fichier

J'aurais aimé un critère supplémentaire qui dit que si la photo correspondant à la cellule est n'existe pas dans le dossier alors laisser le commentaire vide ou annotation "photo KO"

Deuxième question, sur la ligne :
For I = 1 To 1600
J'aurais souhaité qu'au lieu de s'arrêter à la ligne 1600, la macro s'arrête lorsqu'il n'y a plus de text dans la cellule.

Merci d'avance à tout le monde,

Bonjour,
L'instruction "Dir" peut faire cela
Essaye comme ceci

Sub test_photo()
    Dim DossierImages As String, Fichier As String, I As Integer, Nom As Variant
    For I = 1 To 1600
        Nom = Cells(I, 2).Value
        DossierImages = "C:\Users\v.h\Desktop\TEST MACRO PHOTO\"
        Fichier = Nom & ".jpg"
        With Cells(I, 2)
            .ClearComments
            .AddComment
            .Comment.Text Text:=""
            With .Comment
                If Dir(DossierImages & Fichier) <> "" Then
                    .Shape.Fill.UserPicture DossierImages & Fichier
                    .Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
                    .Shape.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
                    .Shape.LockAspectRatio = msoFalse
                    .Shape.Height = 159.75
                    .Shape.Width = 120#
                Else
                    .Text Text:="Photo inexistante"
                End If
            End With
        End With
    Next
End Sub

 

[VAEA]

merci beaucoup à tout le monde, sur les phases test tout fonctionne 🙂