Insertion d'image en VBA Excel 2007 à partir d'un tableau de donnéesRésolu

Question

Bonjour,

voilà mon problème :

j'ai une liste de 700 produits avec leurs références dans un tableau excel et j'ai un dossier avec les 700 images nomées par la référence de chacun des produits .

Comment joindre les deux sur une même ligne excel ?

Merci

Theodavid · Accepted Answer

Super Orohena !!!! ça marche vraiement trés bien !

je t'en remerci cela va beaucoup m'aider !!!

Je donne la solution final pour ceux qui sont interessé :

Sub j_espere_que_ca_marche()
    Dim i As Integer, path As String, sep As String, img As String
    sep = Application.PathSeparator
    path = ActiveWorkbook.path & sep & "images" & sep
' balaye les 700 lignes
    For i = 1 To 700
' indique à Excel où insérer l'image
        Cells(i, 2).Select
' insère une image jpg
            img = path & Cells(i, 1).Value & ".jpg"
            If Dir(img) = "" Then
               MsgBox "Image """ & img & """ non trouvée"
            Else
               ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select
            End If
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
            Rows(i).RowHeight = Selection.Height + 10
    Selection.Top = Cells(i, 2).Top
Selection.Left = Cells(i, 2).Left
    Next


End Sub

Bonne continuation à toi  !!

Cordialement

cs_Orohena · Answer

Bonjour Theodavid

Si tes noms de produit sont dans les lignes 1 à 700 de la colonne A, et que ton répertoire d'images s'appelle "images" et se trouve dans le répertoire du classeur Excel, alors le code suivant devrait t'insérer les images dans les lignes 1 à 700 de la colonne B.

Sub j_espere_que_ca_marche()
    Dim i As Integer, path as string, sep as string
    sep = application.pathSeparator
    path = activeWorkbook.path & sep & "images" & sep
' balaye les 700 lignes
    For i = 1 To 700
' indique à Excel où insérer l'image
        Cells(i, 2).Select
' insère une image jpg
            ActiveSheet.Pictures.Insert(path & cells(i,1).value & ".jpg").Select
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
            Rows(i).RowHeight = Selection.Height + 10
    Next
End Sub

Cordialement

Il faut qu'une porte soit ouverte ... ou d'une autre couleur (Pierre Dac)

Theodavid · Answer

Bonjour Orohena,

Tout d'abord je te remerci pour ta réponse si rapide !!

j'ai testé ce programe et VBA me dit que la ligne :
 
ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select

a une erreur, il est apparament impossible de lire la propriété Insert de la classe picture ...

Peux-tu me dire où est les problème ?

Merci beaucoup

cs_Orohena · Answer

A priori, cette erreur signifie qu'un fichier jpg est introuvable. Essaie le code ci-dessous : si un fichier jpg est introuvable, une boîte de message te donnera le chemin de l'image que le programme n'est pas parvenu à insérer. Il te sera plus facile de déboguer.

PS : je suis en Polynésie, et il est tard. Je me reconnecterai vers 18 h (heure de France) pour savoir où tu en es...

Sub j_espere_que_ca_marche()
    Dim i As Integer, path as string, sep as string, img as string
    sep = application.pathSeparator
    path = activeWorkbook.path & sep & "images" & sep
' balaye les 700 lignes

    For i = 1 To 700
' indique à Excel où insérer l'image

        Cells(i, 2).Select
' insère une image jpg

            img = path & cells(i,1).value & ".jpg"
            if dir(img) = "" then
               msgbox "Image """ & img & """ non trouvée"
            else
               ActiveSheet.Pictures.Insert(path & cells(i,1).value & ".jpg").Select
            endif
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts

            Rows(i).RowHeight = Selection.Height + 10
    Next
End Sub

Cordialement

cs_Orohena · Answer

Oups ! c'est mieux de remplacer la ligne
ActiveSheet.Pictures.Insert(path & cells(i,1).value & ".jpg").Select
par la suivante
ActiveSheet.Pictures.Insert(img).Select

Theodavid · Answer

Tout marche si on enlève la dernière ligne

Rows(i).RowHeight = Selection.Height + 10

mais je vais pouvoir me débrouillé sans

dernière quéstion, tu penses que ça serait possible de connecter les images aux cases auquelles elles appartiennent?

cs_Orohena · Answer

Bonjour


Je ne comprends pas bien ta question. Normalement, le code donne le résultat suivant :

Est-ce que tu as la même chose ?
Cordialement

Le flux et le reflux me font marée (Raymond Devos)

Theodavid · Answer

Euuu ... je ne vois pas ce que tu veux me montrer :s

Mais mon problème principal après quelques testes c'est que les images ne s'insèrent pas en face de leurs références et les cellules ne ce dimension pas à l'image ...

J'ai trouvé sur un autre sujet une solution qui m'a l'air sympa mais que je n'arrive pas à coupler avec la tienne :

Sub Insère_Image_Dans_Cellule2()
Application.ScreenUpdating = False
Set image = ActiveSheet.Pictures.Insert _
("D:\Mes documents\Mes images\alien4.gif")
image.TopLeftCell.Select
With Selection
L = .ColumnWidth
H = .RowHeight
End With
With image
.Width = L * 5.286
.Height = H
.Left = .Left + 2
End With
End Sub

Tu crois qu'il serait possible de faire quelque chose d’équivalent ?




Pour mettre en page les images ?

Merci beaucoup :)

cs_Orohena · Answer

Bonjour TheoDavid


Pour éviter de tourner en rond, voilà ce que je te propose :


 Tu me donnes : 
   a) le nom d'un produit
   b) la cellule qui contient ce nom de produit
   c) le chemin d'accès complet de l'image correspondante
   d) la cellule où tu veux insérer l'image

En réponse, je t'enverrai le code qui insèrera l'image dans la cellule indiquée.

Ok ?

Theodavid · Answer

Oroenha,

ok on peut éssayer comme ça,

a) EPD1006147-M
b) D1
c) C:\Users\Théo\Pictures\Excel\images
d) D2
sachant que mon classeur excel est dans le dossier "Excel"

Moi j'ai fait comme ça :

Sub j_espere_que_ca_marche()
    Dim i As Integer, path As String, sep As String, img As String
    sep = Application.PathSeparator
    path = ActiveWorkbook.path & sep & "images" & sep
' balaye les 700 lignes
    For i = 1 To 12
' indique à Excel où insérer l'image
        Cells(i, 2).Select
' insère une image jpg
            img = path & Cells(i, 1).Value & ".jpg"
            If Dir(img) = "" Then
               MsgBox "Image """ & img & """ non trouvée"
            Else
               ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select
            End If
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
            Rows(i).RowHeight = Selection.Height + 10
    Next
End Sub

Le programe marche au final, mais les images ne s'inserent pas au bonne endroit ...

Theodavid · Answer

pardon, le chemin complet serait celui-ci :

C:\Users\Théo\Pictures\Excel\images\EPD1006147-M

cs_Orohena · Answer

Ok, TheoDavid, cela signifie qu'il faut positionner explicitement l'image par ses propriétés top et left. Pour cela, je te suggère d'insérer les deux instructions ci-dessous juste avant la ligne "Next" :

selection.top = cells(i,2).top
selection.left = cells(i,2).left

cordialement

Theodavid · Answer

Orohena,

J'aurais juste un dernier petit point ...
serait il possible d'ajuster la longeur de la cellule à l'image ?

la largeur est bonne mais ça serais encore mieux avec la longeur !
Je pense que ça ne doit pas être trés compliqué à résoudre mais je n'y arrive pas 

Merci encore

cs_Orohena · Answer

Bonjour Theodavid

Peux-tu tester l'instruction suivante, à mettre après l'instruction next :



columns(2).columnWidth = selection.width



Si toutes tes images ont la même largeur, cela devrait suffire.

Cordialement

Theodavid · Answer

Bonjour Orohena,

Ok, parfait :) ça marche nickel

Je viens de me rendre compte que j'ai un autre trés gros soucie ... 

J'ai en fait une base de donnée avec toutes les images qui y sont regroupées, mais il y a plein de dossiers et de sous dossiers pour les trier par catégorie ...

Penses-tu que le programe pourrait aller rechercher les images dans un dossier contenant plusieurs dossiers et 
sous-dossiers ?

Merci

Cordialement

cs_Orohena · Answer

Est-ce que c'est l'utilisateur qui dira au programme où aller chercher l'image, ou bien c'est le programme qui devra se débrouiller ; dans ce cas, à quelles règles devra-t-il obéir ?

Cordialement

Theodavid · Answer

Il faudrait que le programme trouve seul l'adresse de la photo dans le dossier "images"

Cordialement

cs_Orohena · Answer

Bonjour TheoDavid

Si je comprends bien, il faut chercher l'image dans toute l'arborescence du dossier Images. En principe, la solution est la suivante :

1. procédure j_espere_que_ca_marche( ), modifiée 

Sub j_espere_que_ca_marche()
    Dim i As Integer, path As String, sep As String, img As String
    sep =  Application.PathSeparator
    path = ActiveWorkbook.path & sep & "images" & sep
' balaye les 700 lignes   
    For i = 1 To 700
' cherche et insere une image jpg
        img = Cells(i, 1).Value & ".jpg"
        img =  recurseChercheFichier (path, img)
        If img  = "" Then
           MsgBox "Image """ & img & """ non trouvée"
        Else
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
            Rows(i).RowHeight =  Selection.Height + 10
            ActiveSheet.Pictures.Insert(img).Select
            Selection.Top = Cells(i, 2).Top
            Selection.Left = Cells(i, 2).Lef
        endif
    Next
End Sub



 2 . voici la fonction qui cherche un fichier dans l'arborescence d'un répertoire.
Comme elle est réutilisable pour d'autres applications, j'ai banalisé les noms.

Function recurseChercheFichier(rep As String, nomFich As String) As String
'
' recherche récursivement le fichier nomFich dans
' le repertoire rep et dans ses sous-repertoires
'
    Dim fileSys             ' objet representant le systeme de fichiers
    Dim repertoireCourant   ' objet Folder representant le repertoire courant
    Dim sousRepertoires     ' objet Folders representant les sous-repertoires
    Dim sousRepertoire      ' objet Folder representant l'un des sous-repertoires
    Dim sep As String       ' separateur ("" pour Windows)
    Dim cible As String     ' chemin du fichier dans le repertoire courant
    Dim Erreur as Boolean
    sep  = Application.PathSeparator
    Set fileSys =  CreateObject("Scripting.fileSystemObject")
    cible = rep & sep & nomFich ' chemin du fichier dans le repetoire courant
    If fileSys.fileExists(cible) Then
' le fichier a ete trouve dans le repertoire courant
        recurseChercheFichier = cible
        Exit Function
    End If
' creer un objet Folder representant le repertoire courant
    Set repertoireCourant = fileSys.getfolder(rep)
' creer une collection Folders representant les sous-repertoires
    Set sousRepertoires = repertoireCourant.subfolders
' balayer la collection en creant un objet Folder pour chaque sous-repertoire
    on Error GoTo erreurAccesRep
    Erreur = false
    cible = ""
    For Each sousRepertoire In sousRepertoires
' recherche le fichier par iteration
        if not Erreur then cible = _
            recurseChercheFichier(rep & sep & sousRepertoire.Name, nomFich)
' le fichier a ete trouve dans un sous-repertoire
        If cible <> "" Then
            recurseChercheFichier = cible
            Exit Function
        End If
    Next
    on Error GoTo 0
' le fichier n'a ete trouve ni dans le repertoire
' courant ni dans ses sous-repertoires
    recurseChercheFichier = ""
    Exit Function
erreurAccesRep:
    Erreur = True
    resume next
End Function

 3.  Si ça peut t'aider, voici le programme qui m'a servi à mettre au point la fonction recurseChercheFichier()

Sub test()
' recherche le fichier Collines.jpg à partir de C:\Documents and Settings
    Dim chem As String
    chem  = recurseChercheFichier("C:\Documents and Settings", "Collines.jpg")
    MsgBox chem ' affiche "c:\... Echantillons d'images\Collines.jpg"
End Sub

Cordialement

Theodavid · Answer

Bonjour Ohroena,

Ce programme est vraiment trés bien, il recherche rapidement les images c'est vraiment super !! :)

Mais j'ai encore 2 dernières petite choses à te demander :

premièrement :
est ce qu'il serait possible que le programme insert plusieurs images pour la même référence

exemple : mon produit s'appel ADJ1087002

Et mais images s'appelent ADJ1087002-1, ADJ1087002-2, ADJ1087002-3, ADJ1087002-B, 
ADJ1087002-S ou ADJ1087002-M. en gros c'est des ADJ1087002-*

si chaque image pouvait s'insérer dans une case différente ça serait vraiment bien mais c'est pas graver si elle vont dans la même case.

Deuxiemement :

La boîte m'affichant les erreurs m'empeche de lancer la recherche pendant toute une nuit ... serait il possible de l'enlever sans que le programme ne beug quand il n'y a pas d'image ?

Merci encore :) !!

cs_Orohena · Answer

Salut Theodavid

Dis-moi, notre discussion, c'est comme Gloire et Beauté, on sait quand ça commence mais on sait pas quand ça finit ! 

Pour la 2e question : 

j'avais compris qu'à chaque nom de produit correspondait une image. Il paraissait donc logique de signaler toute exception à cette règle par un message. La suppression de l'instruction msgbox ne perturbe pas du tout le déroulement du programme.

Pour la 1e question :
Si on appelle racine le nom de produit, tel que ADJ1087002, et suffixe ce que tu dois concaténer pour obtenir le nom d'une image (suffixe "",  suffixe   "-1", suffixe =  "-2",  suffixe   = "-3"...),


alors il te faut dresser dans un tableau suffixes( ) une liste exhaustive des suffixes utilisés pour tes image.

Dans le code ci-dessous, et pour chaque racine de la colonne A de ta feuille de calcul, la procédure j_espere_que_ca_marche() balaie le tableau suffixes() et recherche l'image racine & suffixe(n) dans l'arborescence. Elle affiche les images trouvées de gauche à droite à partir de la colonne B, en ajustant la hauteur et la largeur de chaque colonne. J'espère être assez clair.




Sub j_espere_que_ca_marche()
    Dim i As Integer, path As String, sep As String, img As String
    Dim racine as string, suffixes as variant, colonne as integer
    Dim j as integer
    suffixes = array("","-1","-2"...) ' dresser une liste exhaustive des suffixes
    sep = Application.PathSeparator
    path = ActiveWorkbook.path & sep & "images" & sep
    For i = 1 To 700

       racine = cells(i, 1).value
       colonne = 1
       largeMax = 0
       for j = 0 to ubound(suffixes)
            img = racine & suffixes(j)
            img = recurseChercheFichier(path, img)
            if img <> "" then
                 colonne = colonne + 1
                 if Selection.Height + 10 > Rows(i).RowHeight then _
                        Rows(i).RowHeight = Selection.Height + 10
                 if Selection.Width > Rows(i).RowWidth then _
                        Rows(i).RowWidth = Selection.Width
                 ActiveSheet.Pictures.Insert(img).Select
                 Selection.Top = Cells(i, colonne).Top
                 Selection.Left = Cells(i, colonne).Lef
                 DoEvents
           endif
       Next
    Next
End Sub



J'ai compilé ce code pour m'assurer qu'il n'avait pas d'erreur, mais je n'ai pas pu le faire tourner puisque je n'ai
pas le jeu d'essai de fichiers qui va bien. Il devrait être plus gourmand en temps machine que le précédent, c'est pourquoi j'ai mis un DoEvents pour que tu puisses avoir la main pendant qu'il travaille.





Une recherche à partir du caractère générique * est possible mais je l'exclus, car la modification de la procédure recurseChercheFichier pour la rendre récursive à la fois sur l'arborescence et sur la racine ferait d'elle une vraie usine à gaz et me cataloguerait dans la catégorie bidouilleurs.

Insertion d'image en VBA Excel 2007 à partir d'un tableau de données

21 réponses

Votre réponse

Discussions similaires