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 |
