Importation automatique photos dans fichier Excel

Actuellement je gère la base de données d'une association sous access

Le transfert des données se fera via Excel (j'extraie une partie des données vers Excel et les importe ensuite vers le site).

Pour le moment, dans Access je peux afficher la photo de chaque adhérent via un lien qui va chercher la photo dans mon ordi

Je fais simple avec la procédure :

Me.NomDeChemin = Me.Nom_Adherent & " " & Me.Prenom_Adherent & ".jpg"

est le nom sous lequel est enrtegistrée la photo : le nom suivi du prénom de l'adhérent (Dupont Michel.jpg)

Les photos sont stockées dans le dossier suivant ; elles font entre 5 et 50 ko chacune

="O:\Hervé\AHA\Photosbmp\Jpg"

Le tout marche parfaitement bien et permet surtout de ne pas stocker les photos dans la base afin de ne pas l'alourdir.

Pour le transfert des données entre Excel et le site, est-il possible d'afficher dans mon fichier Excel (qui comprendrait entre autre une colonne nom et une colonne prénom) une colonne où apparaitrait la photo de chaque adhérent ?

Je précise que contrairement à Access, ce n'est pas un lien que je veux mais la photo de chacun.

Par ailleurs, il faudrait que cela se fasse en une seule manip (j'ai 600 photos à afficher)

Merci de votre aide.

A+

C15

Bonjour,

Voici un essai avec les noms en colonne 1, les prénoms en colonne 2 et les images à importer en colonne 3 :

sub importerimg()
racine = "O:\Hervé\AHA\Photosbmp\Jpg\" 'dossier
with activesheet 'avec feuille active
    dl = .cells(.rows.count, 1).end(xlup).row 'dernière ligne en colonne 1
    .columns(3).columnwidth = 15 'ajustement largeur colonne 3
    .rows("2:" & dl).rowheight = 75   'ajustement hauteur des lignes
    for i = 2 to dl 'pour chaque ligne
        chemin = racine & .Cells(i, 1).value & " " & .cells(i, 2).value & ".jpg" 'chemin complet image : racine, nom, " ", prenom, ".jpg"
        if dir(chemin) <> "" then 'si le fichier existe
            'ajout image indépendante du fichier d'origine, qui s'adapte aux dimensions de la cellule en cours (colonne 3)
            with .shapes.addpicture(chemin, msofalse, msotrue, .cells(i, 3).left, .cells(i, 3).top, .cells(i, 3).width, .cells(i, 3).height)
                .name = .Cells(i, 1).value & "_" & .cells(i, 2).value 'on la renomme nom_prenom
            end with
        end if
    next i
end with
end sub

Cdlt,

Bonsoir

Merci de cette réponse

Questions bêtes :

Cette procédure je la mets où et je la déclenche comment ?

A+

C15

Rebonjour,

J'ai copié la procédure dans un vbaprojet/feuil1 (R_pour_exportation) et l'ai exécuté par Execution/executer sub/userform

Cela ne marche que pour la 1ère photo

j'ai le message d'erreur 438 "Propriété ou méthode non gérée par cet objet"

Je n'ai pas de référence manquante

On ne doit être très loin.

Merci de ton aide

C15

Essaies celle-ci qui insère les photos sans déformation :

Option Explicit

Sub Incorporer_Photos()
Dim image As Picture
Dim cellule As Range
Dim dossier$, nom$, photo$
Dim derniereLigne&, ligne&, marge%
Dim orientation#

  Call Enlever_Photos
  dossier = "O:\Hervé\AHA\Photosbmp\Jpg\"
  With Worksheets("Feuil1")
    derniereLigne = .Columns("A").Find("*", , , , , xlPrevious).Row
    ' Dimensionner les cellules de destination
    .Columns("C").ColumnWidth = 22.14
    .Rows("2:" & derniereLigne).RowHeight = 120
    marge = 5
    ' Placer les photos
    For ligne = 2 To derniereLigne
      nom = .Cells(ligne, "A") & " " & .Cells(ligne, "B")   'Nom Prénom
      photo = dossier & nom & ".jpg"                        '...\Nom Prénom.jpg
      If Dir(photo) <> "" Then
        Set cellule = .Cells(ligne, "C")                    'Destination
        Set image = ActiveSheet.Pictures.Insert(photo)
        With image.ShapeRange
          ' Position
          .Top = cellule.Top + marge
          .Left = cellule.Left + marge
          ' Adapter la taille selon l'orientation
          orientation = image.Width / image.Height
          If orientation < 1 Then
            ' Portrait
            .LockAspectRatio = msoTrue
            .Height = cellule.Height - 2 * marge
            If .Width > cellule.Width - 2 * marge Then .Width = cellule.Width - 2 * marge
            .Top = cellule.Top + (cellule.Height - .Height) / 2
            .Left = cellule.Left + (cellule.Width - .Width) / 2
          Else
            ' Paysage
            .LockAspectRatio = msoTrue
            .Width = cellule.Width - 2 * marge
            If .Height > cellule.Height - 2 * marge Then .Height = cellule.Height - 2 * marge
            .Top = cellule.Top + (cellule.Height - .Height) / 2
            .Left = cellule.Left + (cellule.Width - .Width) / 2
          End If
          .Name = nom
        End With
      End If
    Next
  End With

End Sub

Sub Enlever_Photos()
Dim forme As Shape

  For Each forme In Worksheets("Feuil1").Shapes
    If forme.Type = msoPicture Then
      forme.Delete
    End If
  Next forme
  Worksheets("Feuil1").UsedRange.Offset(1).Rows.AutoFit

End Sub

:

Bonsoir

Au bout du 2ième essai cela a l'air de fonctionner.

Je vérifie tout cela ce week-end et reviens vers toi...pour dire que cela marche parfaitement

Bon week-end

C15

Bonjour à tous,

Oui, mon code comporte une petite erreur sur la ligne prévue pour renommer les images. Voici un essai de correction :

sub importerimg()
racine = "O:\Hervé\AHA\Photosbmp\Jpg\" 'dossier
with activesheet 'avec feuille active
    dl = .cells(.rows.count, 1).end(xlup).row 'dernière ligne en colonne 1
    .columns(3).columnwidth = 15 'ajustement largeur colonne 3
    .rows("2:" & dl).rowheight = 75   'ajustement hauteur des lignes
    for i = 2 to dl 'pour chaque ligne
        chemin = racine & .Cells(i, 1).value & " " & .cells(i, 2).value & ".jpg" 'chemin complet image : racine, nom, " ", prenom, ".jpg"
        if dir(chemin) <> "" then 'si le fichier existe
            'ajout image indépendante du fichier d'origine, qui s'adapte aux dimensions de la cellule en cours (colonne 3)
            with .shapes.addpicture(chemin, msofalse, msotrue, .cells(i, 3).left, .cells(i, 3).top, .cells(i, 3).width, .cells(i, 3).height)
                .name = .parent.Cells(i, 1).value & "_" & .parent.cells(i, 2).value 'on la renomme nom_prenom
            end with
        end if
    next i
end with
end sub

Cdlt,

Bonjour,

Honnêtement je n'ai pas vu cette erreur.

Au final, j'ai testé tes 2 dernières procédures, elles fonctionnent toutes les 2 mais je préfère l'avant dernière car les photos ne sont pas déformées (dans la dernière,elles sont écrasées en largeur).

Dans tous les cas bravo et merci pour ton aide.

C15

c15lachapelle a écrit :

j'ai le message d'erreur 438 "Propriété ou méthode non gérée par cet objet"

!!!

Bonjour,Honnêtement je n'ai pas vu cette erreur

???

Bonsoir à tous les deux,

Pour vous rassurer tous les 2, j'ai testé vos 2 procédures , l'une et l'autre fonctionnent parfaitement !

Concernant mes observations :

1 j'ai le message d'erreur 438 "Propriété ou méthode non gérée par cet objet"

Cela est du au fait que mon feuillet ne s’appelait pas Feuil1 ; je l'ai renommé

2 Bonjour,Honnêtement je n'ai pas vu cette erreur

Je n'ai pas vu où se situait l'erreur signalée et corrigée par 3GB

Merci encore à tous les deux, cela correspond parfaitement à ce que je voulais

C15

Bonsoir à tous les deux,

Avec le nom du feuillet, vous auriez eu une erreur de type 9. Mon erreur était :

.name = .Cells(i, 1).value & "_" & .cells(i, 2).value 'on la renomme nom_prenom

corrigée ainsi :

.name = .parent.Cells(i, 1).value & "_" & .parent.cells(i, 2).value 'on la renomme nom_prenom

L'objet courant (dans le bloc with) est une forme (shape) obtenue suite à l'ajout (méthode .addpicture). Les formes n'ont pas de cellule. J'ai donc rajouté la propriété .parent qui renvoie le parent de la forme, à savoir la feuille contenant la forme en question. Ainsi, les cellules sont bien ciblées car je pointe la bon objet.

En tout cas, tant mieux si ça fonctionne et merci du retour !

Cdlt,

Je sais que le sujet est clos mais je poste quand même un dernier code, après essais cette fois, pour ce problème de déformation des images.

Avec ce code, chez moi en tout cas, les images restent aux mêmes proportions, ajustées à la hauteur des lignes définie avant :

sub importerimg()
racine = "O:\Hervé\AHA\Photosbmp\Jpg\" 'dossier
with activesheet 'avec feuille active
    dl = .cells(.rows.count, 1).end(xlup).row 'dernière ligne en colonne 1
    .rows("2:" & dl).rowheight = 75   'ajustement hauteur des lignes
    for i = 2 to dl 'pour chaque ligne
        chemin = racine & .Cells(i, 1).value & " " & .cells(i, 2).value & ".jpg" 'chemin complet image : racine, nom, " ", prenom, ".jpg"
        if dir(chemin) <> "" then 'si le fichier existe
            'ajout image indépendante du fichier d'origine, qui s'adapte aux dimensions de la cellule en cours (colonne 3)
            with .shapes.addpicture(chemin, msofalse, msotrue, .cells(i, 3).left, .cells(i, 3).top, -1, -1)
                .Height = .Parent.Rows(i).RowHeight
                .name = .parent.Cells(i, 1).value & "_" & .parent.cells(i, 2).value 'on la renomme nom_prenom
            end with
        end if
    next i
end with
end sub

Cdlt,

Bonsoir

Merci ce la fonctionne très bien

Cordialement

C15