Compléter un tableau Excel

**Ric500** · 07/12/2021, 11h06

Bonjour forum !

Je viens vers vous cette fois-ci pour un problème qui me paraissait simple au début.

J'ai une requête avec jointure d'une table "A" vers une table "B".
"A" contient des enregistrements
"B" contient une clé externe de "A" et un champ texte avec le chemin vers une (ou des) photos associées.

Je voudrais générer un fichier excel sur le modèle suivant:

x Ligne 1 - champ1 - champ2 - ...

photo associée n°1
photo associée n°2
photo associée n°3

x Ligne2 - ...

Là où le bât blesse, c'est que le champ "photo associée" est un champ texte et, en regard de chaque ligne du tableau excel, j'aimerais avoir un contrôle image avec l'image correspondante.

Croyez-vous cela possible ?

Merci d'avance pour vos réponses.

**Zekraoui_Jakani** · 07/12/2021, 13h19

Oui, moyennant l'insertion d'un hyperlien en remplacement de votre zone de texte; mais je ne sais pas si ça correspond à ce que vous cherchez

**Ric500** · 07/12/2021, 16h09

Merci Zekraoui_Jakani pour ta réponse rapide

En fait mon cahier des charges a un peu évolué: je suis en train de coder une petite procédure qui fait le boulot par automation.
Çà a l'air de fonctionner (même si c'est peu performant). Dans l'idée, pour la table fille, je me limite aux trois premières photos (si elles existent) et je souhaite les afficher sur une même ligne, côte à côte.

donc:

Ligne 1 sans photos ...
Ligne 2 sans photos ...
Ligne 3 avec photos ...

[Photo 1] [Photo 2] [Photo 3]

Ligne 4 sans photos ...

Dans mon code, je ne suis pas spécialiste de l'automation, je cherche à créer des shapes dans lesquelles insérer les images (boucle Do While en bleu)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
Sub Export_Catalogue_Automation()
    Dim xlApp As Object
    Dim xlSheet As Object
    Dim xlBook As Object
    Dim shpPhoto As Object
    Dim I As Long, J As Long, noInv As Long, maxPhotos As Integer, x As Integer, nbFoundPhotos As Integer
    Dim t0 As Long, t1 As Long
    Dim strSQL As String, chemPhoto As String
    Dim rec As Recordset, recPhoto As Recordset
    
    t0 = Timer
    maxPhotos = 3
    strSQL = "SELECT ARTEFACT.Numéro, ARTEFACT.[Numéro d'inventaire], ARTEFACT.Indice, Référentiel_C.[Référentiel Carroyage], Classe.[Nom de Classe] AS Classe, Type.[Nom de type] AS Type, Genre.[Nom de Genre] AS Genre, Matière.[Nom de Matière] AS Matière, Etat.[Nom d'Etat] AS Etat, " & _
        "Motif.[Nom de Motif] AS Motif, ARTEFACT.RR, ARTEFACT.XLR, ARTEFACT.YLR, ARTEFACT.ZLR, ARTEFACT.Diamètre1, ARTEFACT.Diamètre2, ARTEFACT.Diamètre3, ARTEFACT.Longueur, ARTEFACT.Largeur, ARTEFACT.Hauteur, ARTEFACT.Epaisseur, ARTEFACT.[Epaisseur 2], ARTEFACT.[Epaisseur 3], " & _
        "ARTEFACT.Poids, ARTEFACT.Unité_Poids, ARTEFACT.Datation, ARTEFACT.Remarques2, ARTEFACT.Description2, Pate.Texture, ARTEFACT.Bord, ARTEFACT.Panse, ARTEFACT.Fond, ARTEFACT.Anse, ARTEFACT.Pate_Couleur, ARTEFACT.Pate_Inclusion, Four.Four, Origine.Origine, Fabrique.Fabrique, ARTEFACT.Décor, " & _
        "ARTEFACT.Motif2, Couverte_Aspect.Couverte_Aspect, Couverte_Composition.Couverte_Composition, Couverte_Texture.Couverte_Texture, ARTEFACT.Avers, ARTEFACT.Revers, ARTEFACT.Axe, ARTEFACT.Engobe_Ext_Couleur, ARTEFACT.Engobe_Int_Couleur, ARTEFACT.Engobe_Ext_Texture AS TextureExt, " & _
        "ARTEFACT.Engobe_Int_Texture AS TextureInt, Céram_Décor_Situation.Décor_Situation, Céram_Décor_Technique.Décor_Technique, ARTEFACT.Ref_Document " & _
        "FROM ((((((((((((Etat RIGHT JOIN (Matière RIGHT JOIN (Genre RIGHT JOIN (Type RIGHT JOIN (Classe RIGHT JOIN (Référentiel_C RIGHT JOIN ARTEFACT ON Référentiel_C.[Num Référentiel_C] = ARTEFACT.[Référentiel Carroyage]) ON Classe.Classe = ARTEFACT.Classe) ON Type.Type = ARTEFACT.Type) ON Genre.Genre =  " & _
        "ARTEFACT.Genre) ON Matière.Matière = ARTEFACT.Matière) ON Etat.Etat = ARTEFACT.Etat) LEFT JOIN Motif ON ARTEFACT.Motif = Motif.Motif) LEFT JOIN Pate ON ARTEFACT.Pate_Texture = Pate.N°_Pate) LEFT JOIN Four ON ARTEFACT.Four = Four.N°) LEFT JOIN Engobe_Ext ON ARTEFACT.Engobe_Ext_Texture =  " & _
        "Engobe_Ext.N°_Engobe) LEFT JOIN Engobe_Int ON ARTEFACT.Engobe_Int_Texture = Engobe_Int.N°_Engobe) LEFT JOIN Céram_Décor_Situation ON ARTEFACT.[Céram_ Décor_Situation] = Céram_Décor_Situation.[N° Décor_Situation]) LEFT JOIN Céram_Décor_Technique ON ARTEFACT.[Céram_ Décor_Technique] =  " & _
        "Céram_Décor_Technique.[N° Décor_Technique]) LEFT JOIN Origine ON ARTEFACT.Origine = Origine.N°) LEFT JOIN Fabrique ON ARTEFACT.Fabrique = Fabrique.N°) LEFT JOIN Couverte_Texture ON ARTEFACT.Couverte_Texture = Couverte_Texture.N°) LEFT JOIN Couverte_Aspect ON ARTEFACT.Couverte_Aspect =  " & _
        "Couverte_Aspect.N°) LEFT JOIN Couverte_Composition ON ARTEFACT.Couverte_Composition = Couverte_Composition.N° " & _
        "WHERE (((ARTEFACT.[Select])=True)) " & _
        "ORDER BY ARTEFACT.[Numéro d'inventaire];"
    
    Set rec = CurrentDb.OpenRecordset(strSQL)
    CréeRequeteTempo (strSQL)
    
    'Initialisations
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    
   
    'Ajouter une feuille de calcul
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Catalogue "             '& Format(Now, "dd-mm-yy hh:nn")
    
    
    ' les entetes
    '  .Fields(Index).Name renvoie le nom du champ
    For J = 0 To rec.Fields.Count - 1
        xlSheet.Cells(1, J + 1) = rec.Fields(J).Name
        ' Nous appliquons des enrichissements de format aux cellules
        With xlSheet.Cells(1, J + 1)
            .Interior.ColorIndex = 15
            .Interior.Pattern = 1
            .Borders(9).LineStyle = 1
            .Borders(9).Weight = 2
            .Borders(9).ColorIndex = -4105
            .HorizontalAlignment = -4108
        End With
    Next J
    
        
    ' recopie des données à partir de la ligne 2
    I = 2
    Do While Not rec.EOF
        For J = 0 To rec.Fields.Count - 1
                ' .Fields(Index).Type renvoie le type du champ
                '   si c'est un Texte (dbText) nous insérons "'" pour
                '   qu'il soit reconnu par Excel comme du Texte
                If rec.Fields(J).Type = dbText Then
                    xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
                Else
                    xlSheet.Cells(I, J + 1) = rec.Fields(J)
                End If
                xlSheet.Cells(I, J + 1).RowHeight = 15
                
        Next J
        
        ' Insère une ligne si il existe au moins une photo
        strSQL = "SELECT TOP 3 T_GED.GEDUnik, T_GED.GEDN°Artefact, T_GED.GEDFullPath FROM T_GED WHERE GEDNomFouille='" & DFirst("[Nom de manip]", "IDENTIFICATION") & "' AND GEDN°Artefact=" & rec.Fields("Numéro") & " AND GEDIsPrint=True;"
        
        Set recPhoto = CurrentDb.OpenRecordset(strSQL)
        With recPhoto
            If .EOF Then
                .Close
                Else
                .MoveLast
                .MoveFirst
                nbFoundPhotos = .RecordCount
                I = I + 1
                Do While .EOF = 0
                    chemPhoto = !GEDFullPath
                    xlSheet.Cells(I, 3 + .AbsolutePosition).RowHeight = 45
                    xlSheet.Rows(I).VerticalAlignment = -4108
                    xlSheet.Cells(I, 3 + .AbsolutePosition) = chemPhoto 
                    ' Insère l'image
                    If Dir(chemPhoto ) <> "" Then
                        Set shpPhoto = ActiveSheet.Shapes.AddPicture(FileName:=chemPhoto, Linktofile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
                    End If
                    .MoveNext
                Loop
                .Close
            End If
        End With
        Set recPhoto = Nothing
        
        
        I = I + 1
        rec.MoveNext
    Loop

    ' code de fermeture et libération des objets
    xlBook.SaveAs RenFichier2(CurrentProject.Path & "\Catalogue.xlsx")
    xlApp.Quit
    rec.Close
    Set rec = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

    t1 = Timer
    Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"

End Sub

... Mais les infos que j'ai pu trouver là-dessus sont incomplètes : il me semble que ce "Shapes.AddPicture" ne me permet pas de mettre mes photos dans une cellule.

**Zekraoui_Jakani** · 07/12/2021, 17h40

Chez moi, ça marche avec l'instruction:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ActiveSheet.Pictures.Insert("C:\Users\BlaBla\Documents\Identité\maPhoto.jpg").Select

l'image "maPhoto" est préalablement enregistrée dans le bon répertoire via Access

Compléter un tableau Excel [AC-365]

VBA Access

Vue hybride

Discussions similaires

Partager

Partager