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 18316 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 26 avril 2024 - 11 mars 2011 à 17:37
Mike-31 Messages postés 18316 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 26 avril 2024 - 11 mars 2011 à 17:37
A voir également:
- Insérer une image dans une cellule excel vba
- Frédéric cherche à faire le buzz sur les réseaux sociaux. il a ajouté une image de manchots sur une image de plage. retrouvez l'image originale de la plage. que cachent les manchots ? ✓ - Forum Windows
- Aller à la ligne dans une cellule excel - Guide
- Insérer liste déroulante excel - Guide
- Insérer une vidéo dans powerpoint - Guide
- Verrouiller cellule excel - Guide
11 réponses
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
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
