Insérer photos d'un dossiers dans feuille excel

[billouu]

Bonjour,

Je souhaiterais insérer plusieurs photos d'un dossier en donnant le nom du dossier à l'aide d'une message box de type parcourir et que l'ensemble de photos s'insère les une sous les autres aux dimensions de la cellule.

Voici le début de la macro:

Private Sub CommandButton1_Click()






Dim ficimg As Variant
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With



End Sub

D'avance merci.

Billouu

 

[billouu]

Re : Insérer photos d'un dossiers dans feuille excel

Re,

J'ai une macro qui fonctionne bien seulement par moment des photos ne sont pas insérés. Sauriez vous pourquoi?
Voici la macro:

Private Sub ButtonOk_Click() 'ceci si on utilise l'userf présent

On Error GoTo Fin

For x = 1 To 50000

Cells(x + 10, 3).Activate
Dim photo As Variant
photo = TextBox3.Value & "\0 (" & x & ").jpg"


ActiveSheet.Pictures.Insert(photo).Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Next x
Fin:

If x = 1 Then
MsgBox "Vérifiez que vos photos soit nommées comme ceci : 0 (1), 0 (2),... " & Chr(10) & "Pour cela, sélectionner toutes les photos du dossier puis faite renommer sur la première et appuyer sur 0"
Exit Sub

End If

If Err.Number = 18 Then MsgBox "Opération annulée."

Unload Me
End Sub

D'avance merci

 

[MJ13]

Re : Insérer photos d'un dossiers dans feuille excel

Bonjour Billouu

Avec ce fichier, cela pourrait t'inspirer.

 

[DoubleZero]

Re : Insérer photos d'un dossiers dans feuille excel

Bonjour à toutes et à tous,

Je ne peux rester sans "dire" : Merci, Michel , pour ton superbe travail.

A bientôt

 

[billouu]

Re : Insérer photos d'un dossiers dans feuille excel

Merci Michel,

Mais je cherche également à les compresser....

 

[MJ13]

Re : Insérer photos d'un dossiers dans feuille excel

Re, Bonjour 00

Tiens regarde là, c'était d'ailleurs le premier like que j'ai reçu sur XLD qui venait de 00, il me semble. Merci 00

https://www.excel-downloads.com/thr...-suppression-photos-mouton-a-5-pattes.154875/