1 pièce(s) jointe(s)
Insérer des photos dans un tableau avec le nom des photos
Bonjour à tous,
J'ai lu plusieurs articles, mais ne trouve pas la solution à mon problème. Comme beaucoup d'utilisateurs, je dois insérer de nombreuses photos dans un fichier Word. Et voici ce que j'aimerais faire :
1. Insérer un tableau à l'endroit où se trouve le curseur
Deux colonnes : largeurs de 9 cm
Trois lignes : Hauteurs fixes : 1ère ligne 5 cm de haut, 2ème ligne 0.5 cm de haut, 3ème ligne 0.1 cm de haut
Bordures : visible pour les deux premières lignes et non visible pour la troisième ligne
Alignement du tableau : centré
Alignement à l'intérieur du tableau : centré
2. Insérer toutes les photos contenus dans un certain dossier que je choisis à chaque activation de la macro
Première ligne : insertion d'une photo par colonnes
Deuxième ligne : insertion du nom des photos sans l'extension
Troisième ligne : rien
3. Puis s'il y a plus de 2 photos dans le dossiers
Créer trois lignes supplémentaires selon les indication du point 1
Insérer les photos suivantes et noms de photos selon les indications du point 2
4. Répétez l'opération jusqu'à ce que toutes les photos et noms de photos aient été insérés
J'ai déjà un bout de code créé par un utilisateur nommé JP et quelque peu modifié par mes soins, mais qui ne fait pas exactement cela. Notamment le code insère les photos dans un tableau dimensionné pré-existant. Le voici :
Code:
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
| Sub InsertionImages()
' J.P Octobre 2016
Dim Repertoire As String
Dim Extension As String
Dim Fichier As String
Dim intResult As Integer
Dim strPath As String
Dim MonTableau As Table
' on prend le premier tableau du document
Set MonTableau = ActiveDocument.Tables(1)
'La fenêtre de choix de répertoire est affichée
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'On sort si le choix du répertoire a été annulé
If intResult = 0 Then Exit Sub
Repertoire = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
'Saisie du type d'extension
Extension = InputBox("Type de fichier (sans le point, ex : jpg, png, bmp)", "Type de fichier", "jpg")
'Récupération du premier fichier du répertoire
Fichier = Dir(Repertoire & "*" & Extension, vbDirectory)
Do While Fichier <> ""
InsérerImage MonTableau, Repertoire & Fichier
'Récupération du prochain fichier du répertoire
Fichier = Dir
Loop
End Sub
Function CréerNewLgTableau(MonTableau) As Cell
'Création de 3 lignes
'une ligne d'images , une ligne de descriptifs, une ligne de séparation
Dim rowNew As Row
'ligne photo
Set rowNew = MonTableau.Rows.Add
rowNew.Height = MillimetersToPoints(50)
' on retourne la première cellule de la ligne photo
Set CréerNewLgTableau = rowNew.Cells(1)
'ligne descriptif
Set rowNew = MonTableau.Rows.Add
rowNew.Height = MillimetersToPoints(5)
rowNew.Cells(1).Range.Text = "Descriptif"
rowNew.Cells(2).Range.Text = "Descriptif"
'ligne de séparation
Set rowNew = MonTableau.Rows.Add
rowNew.Height = MillimetersToPoints(1)
End Function
Sub InsérerImage(MonTableau, FichierImage)
Dim CellVideOK As Boolean
CellVideOK = False
'Recherche de la première cellule vide dans le tableau
Debug.Print MonTableau.Rows.Count
For Each Ligne In MonTableau.Rows
'on ne teste que les lignes modulo 3 (ligne 1, 4 etc)
If (Ligne.Index - 1) Mod 3 = 0 Then
'on ne prend que les cellules de colonne 1,2
For x = 1 To 2 Step 1
'test si cellule vide
If Ligne.Cells(x).Range.Text = Chr(13) & Chr(7) Then
CellVideOK = True
Ligne.Cells(x).Range.InlineShapes.AddPicture FileName:=FichierImage
Exit Sub
End If
Next
End If
Next
'si aucune cellule libre n'a été trouvée on crée une série de nouvelles lignes
If Not CellVideOK Then
CréerNewLgTableau(MonTableau).Range.InlineShapes.AddPicture FileName:=FichierImage
End If
End Sub |
Et voici le fichier Word que j'ai :
Pièce jointe 543253
Je vous remercie d'ores et déjà pour votre aide précieuse.
Excellente journée à vous tous.
