Discussion :

[lp29200]

Bonjour à tous,

Je lance un appel à l'aide concernant une macro d'import d'images, sur laquelle j'ai un petit problème mais je n'arrive pas à trouver d'où vient l'erreur !

Pour information : cette macro permet d'importer des images correspondant à une liste de références.

Au lancement de la macro, l'utilisateur doit préciser :
1. Le format du texte à rechercher
2. Le répertoire d'où importer la photo (la macro recherche donc le format précisé auparavant dans le répertoire et importe la photo correspondante).

Cependant, cela se corse lorsqu'une référence ne correspond à aucune photo !
Imaginons que, parmi une liste de 10 références, la photo de la référence 1 se charge sur la cellule de la référence 1; la photo de la référence 2 se charge sur la cellule de la référence 2... Mais arrivé à la ligne 3, pas d'image correspondant à la référence 3 ! Au lieu de sauter donc cette ligne et poursuivre tranquillement à la ligne 4, la macro me déplace l'image importée de la référence 2 à l'emplacement de la référence 3. Cela décale donc tout ! Et sur des longues listes de références, c'est long de le corriger à la mano...

Je vous envoie ci-joint le code, si quelqu'un peut me donner quelques billes je vous en serais extrêmement reconnaissante !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Public Sub MENU_ImporterImages()
Dim DirectoryImage, SearchString As String
Dim she, FoundAt, objShell As Object, objFolder As Object, oFolderItem As Object
Dim oRange As Range, aCell As Range, bCell As Range
Dim Chemin As String
Dim reponse As String
 
 
 Dim fldr As FileDialog
   reponse = MsgBox("Importer sur toutes les feuilles sélectionnées ", vbYesNo, "Sondage")
     Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = "LIEN"
        If .Show <> -1 Then
            MsgBox "Error"
         Else
 
         Chemin = .SelectedItems(1)
        End If
    End With
 
    Dim Pattern As String ' Ici on sait que l'on demande un Integer
    Pattern = InputBox("Entrez le format de la chaine de la reference : ", "ex : ???????.??", "???????.??")
 
 
    For Each she In ActiveWindow.SelectedSheets
 
    If (she Is ActiveSheet Or reponse = vbYes) Then
    On Error Resume Next
 
    On Error GoTo 0
    If Chemin <> "" Then
 
 
    Set aCell = she.UsedRange.Find(What:=Pattern, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
 
    If Not aCell Is Nothing Then
        'on ajoute l'image
        Dim ficimg As String
        On Error Resume Next
         she.Shapes.AddPicture(Chemin & "\" & Replace(aCell, ".", "-") & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
 
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
 
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
 
        Set bCell = aCell
       Do
            Set aCell = she.UsedRange.FindNext(After:=aCell)
 
            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                 On Error Resume Next
        ficimg = she.Shapes.AddPicture(Chemin & "\" & Replace(aCell, ".", "-") & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
 
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
 
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
            Else
                Exit Do
            End If
        Loop
    End If
    End If
  End If
 Next she
End Sub

Merci et bon week-end,
Lucie

[Philippe Tulliez]

Bonjour,

Cependant, cela se corse lorsqu'une référence ne correspond à aucune photo !

Il est par exemple possible de prévoir une image spécifique avec comme texte "Image non disponible". C'est l'option que j'avais prise dans une démo sur le VBA et les images, il y a quelques années

[lp29200]

Bonjour,

Il est par exemple possible de prévoir une image spécifique avec comme texte "Image non disponible". C'est l'option que j'avais prise dans une démo sur le VBA et les images, il y a quelques années

Bonjour Philippe,

Merci pour votre réponse, cela peut-être en effet une solution.

A quel endroit devrais-je insérer cet élément ?

Désolée, je débute en VBA et je ne maîtrise pas trop...

Merci d'avance pour votre aide !

Bon après-midi

[Philippe Tulliez]

Bonjour,

A quel endroit devrais-je insérer cet élément ?
Désolée, je débute en VBA et je ne maîtrise pas trop..

Et bien à l'endroit où justement on constate que l'image n'est pas présente dans le répertoire soit à la détection de l'erreur.
Mais j'ai vu que tu as mis beaucoup trop de lignes entre le On Error Resume Next et le On Error Goto 0. Ce type d'instruction doit être placée juste à la ligne où l'erreur risque de se manifester et la ligne qui suit on intercepte l'erreur et on place directement après le On Error Goto 0

[lp29200]

Bonjour,

Et bien à l'endroit où justement on constate que l'image n'est pas présente dans le répertoire soit à la détection de l'erreur.
Mais j'ai vu que tu as mis beaucoup trop de lignes entre le On Error Resume Next et le On Error Goto 0. Ce type d'instruction doit être placée juste à la ligne où l'erreur risque de se manifester et la ligne qui suit on intercepte l'erreur et on place directement après le On Error Goto 0

L'erreur est détectée en ligne 77 du code, j'ai essayé de placer un OnError GotTo0 sur la ligne suivante mais ça me bloque donc les imports photos des cellules suivantes. Et j'ai essayé d'insérer un code pour qu'en cas d'erreur, une image "photo non disponible" soit importée mais elle s'importe ensuite sur toutes les cellules suivantes...

Je ne suis pas à l'origine de cette macro, j'essaye de l'adapter à mes besoins (soit import photo d'un listing de plusieurs refs, si erreur ne rien faire et sauter à la cellule suivante et sinon importer la photo correspondance)...
Je me demande quelle est l'utilité du bloc de code à partir de la ligne 77, n'est-ce pas plus simple de faire un loop et répéter l'action d'import de photo de la a-cell sur toutes les cellules suivantes ? Ou en tout cas je n'arrive pas à repérer d'où vient l'erreur, et ça commence à me faire tourner en bourrique

[Philippe Tulliez]

Bonjour,
Je conseille la lecture de ce tutoriel La gestion des erreurs dans Excel

[lp29200]

Bonjour,
Je conseille la lecture de ce tutoriel La gestion des erreurs dans Excel

Le lien ne fonctionne pas..

[Patrice740]

Le lien ne fonctionne pas..

Chez moi il fonctionne parfaitement !

[lp29200]

Chez moi il fonctionne parfaitement !

Au temps pour moi je viens de tester sur mobile et le lien s'ouvre !

Merci !

[Philippe Tulliez]

Bonjour,
Effectivement, d'habitude je teste les liens. Je viens de corriger

Cependant dans le cas qui nous occupe, il n'y a aucune raison d'utiliser la gestion des erreurs si je me réfère à ce que tu as écris : "Pour information cette macro permet d'importer des images correspondant à une liste de références."
En effet si le nom des images se trouvent dans une colonne d'une liste de données il suffit dans la boucle de tester à l'aide de la fonction Dir la présence du fichier image.

Voici un exemple où le nom des images se trouvent dans la colonne nommée Image d'un tableau structuré (ListObject) se trouvant seul dans la feuille avec comme CodeName shtData

Exemple
Ce code parcourt toutes les lignes de la colonne nommée Image et vérifie si le fichier est présent dans le sous-répertoire nommé DataPicture dans le cas contraire il affiche un message
C'est donc à cet endroit qu'il faut placer le chargement ou pas de l'image à l'aide d'un If....Then...Else...End If

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub T()
  ' Déclaration des variables & constantes
  Const SubFolder As String = "\datapicture\"
  Const LabelName As String = "Image"
  Dim oList As ListObject
  Dim Row As Long
  Dim ColumnNumber As Integer
  Dim PictureName As String
  Dim Folder As String
  ' Affectation des variables
  Set oList = shtDb.ListObjects(1)
  Folder = ThisWorkbook.Path & SubFolder
  ' Start
  With oList
   ColumnNumber = .ListColumns(LabelName).Index
   With .DataBodyRange
    For Row = 1 To .Rows.Count
      PictureName = .Cells(Row, ColumnNumber).Value
      If Len(Dir(Folder & PictureName)) = 0 Then MsgBox "L'image " & PictureName & " : non trouvée"
    Next
   End With
  End With
  ' End
  Set oList = Nothing
End Sub

A lire éventuellement

• Apprendre à utiliser les tableaux structurés Excel : création, manipulations et avantages(1)
• VBA – CodeName d’une feuille Excel

Illustration de la liste de données

[lp29200]

Merci Philippe. J'ai réussi à simplifier le code et cela marche.
Je vais maintenant essayer de creuser pour pouvoir rechercher dans plusieurs dossiers en cas d'erreur.

Merci !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Public Sub MENU_ImporterImages()
Dim DirectoryImage, SearchString As String
Dim she, FoundAt, objShell As Object, objFolder As Object, oFolderItem As Object
Dim oRange As Range, aCell As Range, bCell As Range
Dim Chemin As String
Dim reponse As String
 
 
 Dim fldr As FileDialog
     Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = ""
        If .Show = -1 Then
         Chemin = .SelectedItems(1)
         Else
         End
         End If
         End With
 
 
    Dim Pattern As String ' Ici on sait que l'on demande un Integer
    Pattern = InputBox("Entrez le format de la chaine de la reference : ", "ex : ???????.??", "????-???????-??_1")
 
    For Each she In ActiveWindow.SelectedSheets
 
    If (she Is ActiveSheet) Then
    On Error Resume Next
 
    On Error GoTo 0
    If Chemin <> "" Then
 
 
    Set aCell = she.UsedRange.Find(What:=Pattern, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
 
    For Each aCell In she.UsedRange
 
    If Not Len(Dir(Chemin & "\" & aCell & ".jpg")) = 0 Then
    On Error Resume Next
        'on ajoute l'image
        Dim ficimg As String
         she.Shapes.AddPicture(Chemin & "\" & aCell & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
 
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
 
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
 
        Else
 
            End If
        Next aCell
    End If
    End If
 
 Next she
End Sub

[Philippe Tulliez]

Bonjour,

Je vais maintenant essayer de creuser pour pouvoir rechercher dans plusieurs dossiers en cas d'erreur.

C'est à dire ?
Dans l'exemple que j'ai donné, il n'y a pas d'erreur. C'est simplement un fichier qui n'est pas présent dans le répertoire définit par la constante SubFolder

J'ai regardé ton code, je ne vois pas l'intérêt d'utiliser le On Error

Attention que plusieurs variables ne sont pas typées comme par exemple ligne 2 Dim DirectoryImage, SearchString As String seule la variable SearchString est typée

Pour les typées toutes les deux comme String, il faut écrire Dim DirectoryImage As String, SearchString As String

[Pierre Dumas]

[OFF]
Ils ne sont pas jeunes les auteurs dans la liste. Tout un pan d'histoire.
[/OFF]

[Philippe Tulliez]

Bonjour Pierre,
Effectivement.
En général je rafraîchis mes données mais ici, il y a à la fois les textes mais également les images alors c'est un fameux travail mais j'ai bien ces livres dans ma bibliothèque et j'ajouterai que je n'ai pas encore trouvé un livre sur les fonctions d'excel qui atteint le niveau de celui de Laurent Longre

[Pierre Dumas]

[...] Laurent Longre

Le fameux grand chef à trois plumes de mpfe

[lp29200]

Bonjour à tous,

@Philippe, merci pour la correction, j'ai corrigé les variables, elles sont bien toutes typées.

Suite à plusieurs utilisations, la macro fonctionne bien.
Par contre je me rends compte que l'import des images se fait même sur les cellules ne respectant pas le format demandé au lancement de la macro.

Par exemple : à l'ouverture de la macro, je souhaite que le pattern soit le suivant : ???????-?? (pour rechercher les cellules correspondantes à ce format de 10 caractères avec un "-" en 8ème position, et en importer les images correspondantes).
Mais si j'ai une cellule dont le texte est "150" (donc ne correspondant pas au pattern souhaité) et qu'il s'avère qu'il y a une image nommée "150" dans le répertoire recherché, l'image est importée !

Je ne vois pas où ça coince pour limiter la recherche et l'import des photos aux cellules avec le format demandé ?

Pour rappel, le code est le suivant :

Merci pour votre aide !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Public Sub MENU_ImporterImages()
Dim DirectoryImage As String, SearchString As String
Dim she As Object, FoundAt As Object, objShell As Object, objFolder As Object, oFolderItem As Object
Dim aCell As Range
Dim Chemin As String
Dim reponse As String
 
 Dim fldr As FileDialog
     Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = "X:\Saisons"
        If .Show = -1 Then
         Chemin = .SelectedItems(1)
         Else
         End
         End If
         End With
 
 
    Dim Pattern As String ' Ici on sait que l'on demande un Integer
    Pattern = InputBox("Entrez le format de la chaine de la reference : ", "ex : ???????.??", "???????-??_1")
 
    For Each she In ActiveWindow.SelectedSheets
 
    If (she Is ActiveSheet) Then
    On Error Resume Next
 
    On Error GoTo 0
    If Chemin <> "" Then
 
 
    Set aCell = she.UsedRange.Find(What:=Pattern, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
 
    For Each aCell In she.UsedRange
 
    If Not Len(Dir(Chemin & "\" & aCell & ".jpg")) = 0 Then
    On Error Resume Next
        'on ajoute l'image
        Dim ficimg As String
         she.Shapes.AddPicture(Chemin & "\" & aCell & ".jpg", False, True, 0, 0, -1, -1).Select
        With Selection.ShapeRange
            .LockAspectRatio = True
            .Top = aCell.Top + 2
            .Left = aCell.Left
            .Width = aCell.Width
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
            .Height = aCell.Height - 4
            .Left = aCell.Left + ((aCell.Width - Selection.ShapeRange.Width) / 2)
 
            .Top = aCell.MergeArea.Top + 2
            .Left = aCell.MergeArea.Left
            .Width = aCell.MergeArea.Width
            .Height = aCell.MergeArea.Height - 4
            .Left = aCell.Left + ((aCell.MergeArea.Width - Selection.ShapeRange.Width) / 2)
 
            '.AlternativeText = sargs(0)
        End With
        With Selection
        .Locked = False
        .PrintObject = True
        .Placement = xlMoveAndSize
        .ShapeRange.ZOrder msoSendToBack
        '.Name = pict.Name
        End With
 
        Else
 
            End If
        Next aCell
    End If
    End If
 
 Next she
End Sub

[Philippe Tulliez]

Bonjour,

Par exemple : à l'ouverture de la macro, je souhaite que le pattern soit le suivant : ???????-?? (pour rechercher les cellules correspondantes à ce format de 10 caractères avec un "-" en 8ème position, et en importer les images correspondantes).

Les fonctions Texte, comme Mid, Left et Right, permettent de décomposer la chaîne de caractères, Len pour calculer le nombre de caractères. Le tout placé dans une structure décisionnelle comme If ou Select Case
On peut aussi utiliser la fonction Split (voir Utiliser les variables tableaux en VBA Excel)

Mais si j'ai une cellule dont le texte est "150" (donc ne correspondant pas au pattern souhaité) et qu'il s'avère qu'il y a une image nommée "150" dans le répertoire recherché, l'image est importée !

Même chose, vérifier le nom dans la même structure décisionnelle