Macro excel pour inserer une image!

Fermé
ldino Messages postés 4 Date d'inscription jeudi 8 février 2007 Statut Membre Dernière intervention 29 octobre 2008 - 8 févr. 2007 à 20:51
Mike-31 Messages postés 18341 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 14 octobre 2024 - 11 mars 2011 à 17:37
Bonjour,

Novice de la macro, je cherche à crée un fichier excel.
Je souhaiterai crée une macro permettant de récuperer une image dans une banque de donnée image (situé en feuil 2 par exemple) grâce à un n° de lot.
Je souhaiterai l'inserer dans un tableau situé en feuil 1 dans un tableau prévu à cet effet ( dans la cellule F2 de feuil 1 par exemple)

Si possible, il pourrai etre interessant de mettre la photo inséré à un format identique pour toute les references.

La question c'est est ce qu'une macro peut redimmensionner une image?

Sinon, si c'est trop compliqué ou chiant à faire je peux les redimensionner avant avec PSP.

Jéspere que quelqu'un va pouvoir m'aider
Merci d'avance

LG

11 réponses

christian baret
23 juil. 2007 à 09:15
J'ai eu pour ma fille à réaliser un travail similaire
Elle disposait d'une collection de photos dont le nom commençait toujours par une clef (radical) calculé par rapport à des informations présente sur la ligne sélectionnée

Cette collection de photo était présente dans un dossier nommé photos inclus dans le dossier contenant le fichier excel
1er à l'ouverture de la feuille excel, on récupére le dossier du fichier excel pour pouvoir localiser les photos en remplissant une cellule d'un onglet caché baptisé Fichier
Private Sub Workbook_Open()
Sheets("Fichier").Cells(1, 2).Value = Application.ActiveWorkbook.Path + "\photos"
End Sub

Dans la macro principale je dresse la liste des images à afficher dans un tableau Fichier$
Call fabdirectory(radical$)
ReDim Fichier$(20)
J = 1
r$ = Sheets("Fichier").Cells(1, 2).Value
While Sheets("Fichier").Cells(J, 1).Value <> ""
fmax = fmax + 1
Fichier$(fmax) = r$ + "\" + Sheets("Fichier").Cells(J, 1).Value
J = J + 1
Wend
Ensuite je lance l'affichage des images dans un autre onglet Baptisé Fiche et contenant aussi des informations textuelle
Call ChangeImage(Fichier$(), fmax)



Voici le code de la macro fabdirectory

Sub fabdirectory(radical$)
' Renvoie le nom des fichiers image du dossier photos correspondant au radical
repertoire$ = Sheets("Fichier").Cells(1, 2).Value + "\" + radical$ + "*.*"
Sheets("Fichier").Columns("A:A").ClearContents
Myfile = Dir(repertoire$)
While Myfile <> ""
Term$ = Right$(LCase$(Myfile), 4)
If (Term$ = ".jpg") Or (Term$ = ".gif") Or (Term$ = "jpeg") Or (Term$ = ".bmp") Then
k = k + 1
Sheets("Fichier").Cells(k, 1).Value = Myfile
End If
Myfile = Dir
Wend
End Sub

Voici la macro Afficheimage dans l'onglet fiche. A noter que je commence par retirer toutes les images présentes dans cet onglet puis je réinsére toutes les images trouvées dans la recherche précédente les unes en dessous des autres et je les redimensionne une à une pour qu'elles aient toutes une taille homogéne

Sub ChangeImage(Fichier$(), fmax)
Dim objFeuille As Worksheet, objPict(20) As Picture
Sheets("Fiche").Select
' Effacement eventuel des images de l'affichage précédent
On Error Resume Next
For i = 1 To 20
nom$ = "Image" + Trim$(Str$(i))
ActiveSheet.Shapes(nom$).Delete
Next i
On Error GoTo 0
Set objFeuille = Sheets("Fiche")
For i = 1 To fmax
F$ = Fichier$(i)
'Ajout de l'image
Set objPict(i) = objFeuille.Pictures.Insert(F$)
'Determination d'un coeficient de réduction d'image
Largeur = objPict(i).Width
Hauteur = objPict(i).Height
Kh = 300 / Hauteur
Kl = 300 / Largeur
If Kl > Kh Then
k = Kh
Else
k = Kl
End If
' Positionnement et redimentionnement
With objPict(i)
.Name = "Image" + Trim$(Str$(i))
.Left = Range("D4").Left
.Top = Range("D4").Top + Decallage
.ShapeRange.ScaleWidth k, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight k, msoFalse, msoScaleFromTopLeft
End With
' Determination de la position suivante
Decallage = objPict(i).Top + objPict(i).Height + 2
Next i
End Sub
8