XL 2013 Inserer images

[maval]

Bonjour

J'ai sur ma feuille "Liste" deux listes déroulante pour choisir:

1° le continent "G2"
2° le pays "G3"

A l'aide de mon bouton j'ouvre le dossier correspondant au pays ou sont logé mes images.jpg ainsi que les noms des images.

J'aimerais pouvoir copier toutes les images de ce répertoire et les coller dans la feuille nommé "Modele" E5:E69 et G5:G69 en sachant que les images sont des billets et que l'on a recto verso.


Je vous remercie

 

[sousou]

Le principe:
Dans le dossier, je cherche tous les fichier se terminant par recto.xls
Le premier aura comme posimage 1 le second 2.....
Dans place image j'arrive avec le chemin de l'image, et sa position
Je place l'image recto
Je prèlève l'image verso (même début de nom)
je place l'image verso
Au reour j'incrément posimage de 2 (interligne entre l'es images)

 

[maval]

re

Oui la il sont dans la bonne case mais j'ai deus fois la même image recto comme verso

 

[sousou]

Corrige fich par fichv
Tu aurais pu trouver l'erreur

'Même procédure pour l'image verso
fichv = Left(fich, Len(fich) - 9) & "verso.jpg"
col = 7
.Cells(lg, col).Select
Set img = .Pictures.Insert(fichv)'<-------
img.Width = ActiveCell.Width
img.Height = ActiveCell.Height
End With
End Sub

 

[maval]

Re,

Oui Nickel Par contre il nous manque les annotations! style: afrique_du_sud_1_rand_1961_recto ect.....
Peut être les mettre sur la petite ligne entre les images.

Merci beaucoup pour le temps passé

 

[sousou]

Ajoute le nom sous l'image
Sub place(fich, posimage)
With Sheets("modele")
.Activate
'calcul de la cellule ou ranger l'image
col = 5
lg = posimage + 5
Cells(lg, col).Select
'insersion de l'image
Set img = .Pictures.Insert(fich)
'Redimensionnement
img.Width = ActiveCell.Width
img.Height = ActiveCell.Height
' Nom du pays
k1 = InStrRev(fich, "\")
nfich = Mid(fich, k1 + 1, Len(fich) - k1 - 10)
.Cells(lg + 1, col) = nfich

'Même procédure pour l'image verso
fichv = Left(fich, Len(fich) - 9) & "verso.jpg"
col = 7
.Cells(lg, col).Select
Set img = .Pictures.Insert(fich)
img.Width = ActiveCell.Width
img.Height = ActiveCell.Height
' Nom du pays
k1 = InStrRev(fich, "\")
nfich = Mid(fich, k1 + 1, Len(fichv) - k1 - 10)
.Cells(lg + 1, col) = nfich
End With
End Sub

 

[maval]

Re

Une seul chose à dire chapeau bas.
Juste pour chipoter est-il possible de mettre les images au milieu de la colonne comme il n'ont pas toutes les même largeur au moins il serait au milieu

Merci beaucoup pour ton super travail et ta patience

 

[sousou]

tout est possible ou presque
J'ai ajouter une procédure qui calcul la position par rapport à la cellule
correction aussi sur fich au lieu de fichv
Cela ne génait pas parcque fich et fichv étaitent identique, mais c'est plus propre
Sub place(fich, posimage)
With Sheets("modele")
.Activate
'calcul de la cellule ou ranger l'image
col = 5
lg = posimage + 5
Cells(lg, col).Select
'insersion de l'image
Set img = .Pictures.Insert(fich)
'Redimensionnement
img.Width = ActiveCell.Width
img.Height = ActiveCell.Height
Call pos(.Cells(lg, col), img)

' Nom du pays
k1 = InStrRev(fich, "\")
nfich = Mid(fich, k1 + 1, Len(fich) - k1 - 10)
.Cells(lg + 1, col) = nfich

'Même procédure pour l'image verso
fichv = Left(fich, Len(fich) - 9) & "verso.jpg"
col = 7
.Cells(lg, col).Select
Set img = .Pictures.Insert(fich)
img.Width = ActiveCell.Width
img.Height = ActiveCell.Height
Call pos(.Cells(lg, col), img)
' Nom du pays
k1 = InStrRev(fichv, "\")
nfich = Mid(fichv, k1 + 1, Len(fichv) - k1 - 10)
.Cells(lg + 1, col) = nfich
End With
End Sub

Sub pos(cellule, image)
x = cellule.Left
l = cellule.Width
ximage = x + (l / 2) - (image.Width / 2)
image.Left = ximage
End Sub

 

[sousou]

Bon les JO n'attendent pas
Je verrai demain si c'est bon
Bonne chance

 

[maval]

Re,

Nickel je te remercie beaucoup et je te souhaite une bonne soirée avec les JO
Merci encore