Inserer image provenant de dossiers/sous dossiers

Bonjour,

Je travail sur excel 2010.

J'aurais besoin de créer un code vba qui doit faire les actions suivante :

• Je démarre en donnant une référence (ex : "3458" )
• Je chercher cette référence dans un dossier et ses sous dossiers pour trouver des fichiers images de types :

- Si un fichier ou plusieurs sont trouvé j'en sélectionne 1 en privilégiant les format dans un certain ordre :

.gif => .jpg => .bmp

- Puis j'utilise l' adresse complète du fichier pour insérer le fichier dans ma feuille excel.

Nota : je suis au courant que l'objet FileSearch n'est plus supporté depuis Office2007

J'ai testé la solution du complément de silkyroad. Ce complément fonctionne en étant affreusement long pour chaque exécution chez moi. J'aimerais si possible éviter cette solution.

Serait il possible de m'aider a écrire un code pour une solution la plus adapté à mon besoin ?

En vous remerciant par avance.

Voilà un code qui te permet de te donner l'adresse complète de ton fichier en privilegiant gif sur jpg sur bmp.

Il te suffit de le modifier pour au lieu de faire un msgbox, insérer ton image ou tu veux.

Sub chercher(ByVal chemin As String, ByVal image As String)
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.GetFolder(chemin)

For Each f1 In rep.SubFolders
    For Each f2 In f1.Files
        If f2.Name = image & ".gif" Then
           MsgBox (f2.Path)
           Exit Sub
        End If
        If f2.Name = image & ".jpg" Then
           MsgBox (f2.Path)
           Exit Sub
        End If
        If f2.Name = image & ".bmp" Then
           MsgBox (f2.Path)
           Exit Sub
        End If
    Next f2
Next f1

End Sub

Sub toto()
x = InputBox("Le nom de ton image")
Call chercher("C:\Users\User", x)
End Sub

Merci beaucoup de ta réponse ça m'a bien bien fait avancé.

Bonne astuce le double :

"For Each f1 In rep.SubFolders

For Each f2 In f1.Files "

Cela va bien dans chaque sous sous ... dossiers.

Pour info ci-joint mon code complet :

Public Image as Variant

Sub IMPORTATION_IMAGES()

Dim Fichier As String

Dim DL1 As Integer 'Ligne active d'acquisition

Dim DL2 As Integer 'Ligne active de depot

Dim objImg As Variant

Dim Emplacement As Variant

Dim Repertoire As FileDialog

'Vérification AutorisationMacro

Application.Run "VERIFICATION_AUTORISATION.VERIFICATION_AUTORISATION"

AutorisationMacro = "YES"

If AutorisationMacro = "YES" Then

Else

'MsgBox "Autorisation insufisante"

Exit Sub

End If

'Boucle zone d'import

DL11 = Sheets("NOMENCLATURE").Range("B" & Rows.Count).End(xlUp).Row

'DL2 = Sheets("NOMENCLATURE").Range("A:A").Find("ARTICLE", lookat:=xlPart).Row + 1

'Choisir repertoire

Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)

With Repertoire

.InitialFileName = "P:\_R&D Partage\_Mot-dxf\FICHIER-JPG\" '"H:\"

.AllowMultiSelect = False

End With

Repertoire.Show

Adresse_repertoire = Repertoire.SelectedItems(1)

' If Repertoire.SelectedItems.Count > 0 Then _

' MsgBox Repertoire.SelectedItems(1)

For DL2 = 44 To DL11

'VERIFICATION COCHAGE

If (Sheets("NOMENCLATURE").Range("AT" & DL2) <> "") And Sheets("NOMENCLATURE").Range("B" & DL2) <> "" Then

REFERENCE = Sheets("NOMENCLATURE").Range("B" & DL2)

'SELECTION CELLULE

Sheets("NOMENCLATURE").Range("C" & DL2).Select

'Suppression image dans cellule active

For Each s In ActiveSheet.Shapes

If Not Intersect(s.TopLeftCell, ActiveCell) Is Nothing Then s.Delete

Next s

'SELECTION FICHIER

Call chercher(Adresse_repertoire, REFERENCE)

'INSERTION DE L'IMAGE

On Error Resume Next

Set objImg = ActiveSheet.Pictures.Insert(Image)

'Set objImg = ActiveSheet.Shapes.AddPicture(Image, False, True, 0, 0, 10, 100)

Set Emplacement = ActiveCell

If Err.Number > 0 Then

'MsgBox "Image ( " & REFERENCE & " ) non trouvé"

Else

With objImg.ShapeRange

.LockAspectRatio = msoTrue

EchV = (objImg.Height) / (ActiveCell.Height)

EchH = (objImg.Width) / (ActiveCell.Width)

If EchV > EchH Then

objImg.Height = (objImg.Height) / (EchV + 0.5)

.Top = Emplacement.Top + (Emplacement.Height - objImg.Height) / 2

.Left = Emplacement.Left + (Emplacement.Width - objImg.Width) / 2

'.Height = Emplacement.Height - 3

Else

objImg.Height = (objImg.Height) / (EchH + 0.5)

.Top = Emplacement.Top + (Emplacement.Height - objImg.Height) / 2

.Left = Emplacement.Left + (Emplacement.Width - objImg.Width) / 2

'.Width = Emplacement.Width + 3

End If

.Name = REFERENCE

End With

End If

End If

Next

Sheets("NOMENCLATURE").Range("C44").Select

End Sub

Sub chercher(ByVal chemin As String, ByVal REFERENCE As String)

Set fso = CreateObject("Scripting.FileSystemObject")

Set rep = fso.GetFolder(chemin)

For Each f1 In rep.SubFolders

For Each f2 In f1.Files

If f2.Name = REFERENCE & ".gif" Then

Image = f2.Path

MsgBox (f2.Path)

Exit Sub

End If

If f2.Name = REFERENCE & ".jpg" Then

Image = f2.Path

MsgBox (f2.Path)

Exit Sub

End If

If f2.Name = REFERENCE & ".bmp" Then

Image = f2.Path

MsgBox (f2.Path)

Exit Sub

End If

Next f2

Next f1

End Sub

Je ne comprends pas certains points mais ça a l'air correct. Bien joué.

Je te retourne le compliment.

Oui je dois surement coder comme un débutant.

Je n'ai pas du tout eue de formation, j' apprend sur le tas.

Qu est ce que tu ne comprend pas ?

Peux être qu'il y a lieu de simplifier ?

Ta vérification macro sera toujours vérifiée.. a quoi bon la mettre?

Ha oui ca en temps normal j' enlève la ligne :

AutorisationMacro = "YES"

Et la "VERIFICATION_AUTORISATION.VERIFICATION_AUTORISATION" est un autre module qui vérifie le login windows est autorise que certain usagé que je décide à pouvoir utiliser les macros.

Je verrouille aussi mon "VBA project" quand je distribue le fichier.

Public AutorisationMacro As String

Sub VERIFICATION_AUTORISATION()

AutorisationMacro = ""

UserName = Environ("UserName")

'MsgBox UserName

chemin = "H:\LogMacro"

Adr = chemin & "\" & UserName & ".xlsx"

On Error Resume Next

Set Fichier = GetObject(Adr)

If Err.Number > 0 Then

AutorisationMacro = "NO"

'MsgBox AutorisationMacro

Else

AutorisationMacro = "YES"

'MsgBox AutorisationMacro

End If