Insertion image dont les 5 premières lettres sont identique à la référence

[winslow]

Bonjour le forum,
Je suis à la recherche d'un code me permettant d'insèrer des images dans une cellule.
Jusque là, rien de trop difficile..
Le hic, c'est que mes références qui se trouvent en colonne A n'ont pas tout à fait les mêmes noms que mes Jpeg qui se trouve dans mon répertoire.
Je m'explique par un exemple:
une référence dans cellule A1 : B4805
mon image dans mon répertoire : B4805_251007.
Ma réference est toujours composé de 5 caractères qui compose les 5 premiers caractères du nom de mon image.
Les caractères qui suivent mes 5 premiers caractères changent tous les mois.
Donc mon image le mois prochain s'appellera pê B4805_101107
Voici le code que j'ai trouvé et qui fonctionne en suposant que mes 5 premiers caractères sont tjrs suivis de _251007
Merci de m'aider,
David

Sub IntegrationPhoto()
Dim derligne As Integer, i As Integer
Dim chemin As String
Dim image As Object
For Each image In Sheets("Main").Shapes
If image.Name <> "Button 12" Then image.Delete
Next image
derligne = Range("Main!a65536").End(xlUp).Row
For i = 2 To derligne
If Sheets("Main").Range("d" & i) = "x" Then
With Sheets("Main").Range("A" & i)
If Not .Value = "" Then 'gestion cellule vide
chemin = ActiveWorkbook.Path & "\" & .Text & "_251007" & ".jpg"
Set image = ActiveSheet.Pictures.Insert(chemin)
On Error Resume Next
If image.ShapeRange.Height > image.ShapeRange.Width Then
With image.ShapeRange

.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
.Height = Sheets("Main").Range("b" & i).Height
'.Width = Sheets("feuil1").Range("b" & i).Width
End With
Else
With image.ShapeRange
.LockAspectRatio = msoTrue
.Left = Sheets("Main").Range("b" & i).Left
.Top = Sheets("Main").Range("b" & i).Top
'.Height = Emplacement.Height
.Width = Sheets("Main").Range("b" & i).Width
End With
End If
End If
End With
End If
Next i
End Sub

 

[skoobi]

Re : Insertion image dont les 5 premières lettres sont identique à la référence

Bonjour,

fait un essaie en remplaçant la ligne:

 chemin = ActiveWorkbook.Path & "\" & .Text & "_251007" & ".jpg"

par:

With Application.FileSearch
    .LookIn = "C:\le dossier"
    .FileType = msoFileTypeExcelWorkbooks
    .Filename = Sheets("Main").Range("A" & i).Text & "*.jpg"
    .Execute
    If .FoundFiles.Count = 0 Then
        MsgBox "fichier non trouvé"
    Else: chemin = .FoundFiles(1)
    End If
End With

Pense à remplacer "C:\le dossier" par le bon dossier bien sur.

 

[winslow]

Re : Insertion image dont les 5 premières lettres sont identique à la référence

Bonjour Skoobi et merci pour ta réponse,
j'ai encore un souci, lorsque que le fichier n'est pas trouvé (quand la référence n'existe pas dans le répertoire), le système m'insère quand même la dernière photo insèrée auparavant..
merci pour ton aide.

 

[skoobi]

Re : Insertion image dont les 5 premières lettres sont identique à la référence

Re,

dans ce cas, tu crés une condition qui fait que lorsque ce fichier n'existe pas, il va au "i" suivant du genre:

For i = 2 To derligne
trouvé = ""
With Application.FileSearch
.LookIn = "C:\le dossier"
.FileType = msoFileTypeExcelWorkbooks
.Filename = Sheets("Main").Range("A" & i).Text & "*.jpg"
.Execute
If .FoundFiles.Count = 0 Then
trouvé = "non"
Else: chemin = .FoundFiles(1)
End If
End With
If trouvé <> "non" Then

le reste du code ici
.....
.......
End If
Next i
End Sub

 

[winslow]

Re : Insertion image dont les 5 premières lettres sont identique à la référence

Un grand merci pour ton aide.
J'ai simplement changé ceci pour que ça fonctionne..
With Application.FileSearch
.LookIn = "C:\le dossier"
.FileType = msoFileTypeExcelWorkbooks
.Filename = Sheets("Main").Range("A" & i).Text & "*.jpg"
.Execute
If .FoundFiles.Count <> 0 Then
le code
End If
End With