Discussion :

[Brutalis]

Bonjour,

Dans un cadre professionnel, je réalise des rapports sur des bâtiments et je dois intégrer de nombreuses, parfois très nombreuses photos (plusieurs centaines) dans un document Word.

Mon objectif est de créer une macro permettant d'insérer automatiquement toutes les photos d'un dossier dans un/des tableaux de mon document Word ce qui me permettrait d'avoir d'avance ma mise en page type.

En effet, mon fichier word est pré-existant car je rapatrie via une macro des données prises sur le terrain dans un fichier Excel que j'insère dans mon fichier word aux endroits souhaités à l'aide de signets.

Je ne souhaite pas utiliser la même fonction de signets pour les photos car la quantité est très variable.

En revanche, je cale pour les insérer au bon endroit : dans mon tableau pour lequel j'ai fixé mes tailles de cellules.

Je mets en pièce jointe mon fichier Word dans lequel il y a :
- la première page : exemple de ce que je veux obtenir.
- la seconde page : Tableau/grille dans lequel je veux insérer mes photos.

Aujourd'hui, j'arrive à :
- aller chercher mes photos dans le fichier,
- me déplacer de 2 cellules vers la droite (satisfaisant pour les 2 suivantes mais pas pour le changement de ligne)

Il faudrait donc que je puisse avoir une boucle de déplacement qui correspond dans le tableau, ou un détection de cellule vide toutes 2 lignes qui insère une photo quand c'est vide.

Et éventuellement créer autant de pages avec mon tableau qu'il en faut en fonction du nombre de photos, mais là c'est du luxe.

Voilà la macro que j'ai

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
Sub InsertionImages()
 
Dim Repertoire As String
Dim Extension As String
Dim Fichier As String
 
 
'Saisie du nom du répertoire
Repertoire = InputBox("Chemin complet du répertoire (\ à la fin)", "Répertoire", "D:\Mes images")
'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)
 
'Déplacement jusqu'au tableau
Selection.GoTo What:=wdGoToTable, Which:=wdGoToAbsolute
 
Do While Fichier <> ""
    i = i + 1
 
    'Insertion de l'image
    Selection.InlineShapes.AddPicture FileName:=Repertoire & Fichier
 
    'Déplacement dans la cellule suivante
    Selection.MoveRight Unit:=wdCell, Count:=2
 
    'Récupération du prochain fichier du répertoire
    Fichier = Dir
Loop
 
End Sub

Mes notions en VBA sont limités, je ferai mon maximum pour décoder vos conseils et les mettre en oeuvre.

Merci d'avance pour le temps passé et vos lumières.

[jurassic pork]

hello,
tu peux essayer ce code :

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
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", "png")
'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(70)
' 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(15)
 rowNew.Cells(1).Range.Text = "Descriptif"
 rowNew.Cells(3).Range.Text = "Descriptif"
 rowNew.Cells(5).Range.Text = "Descriptif"
'ligne de séparation 
Set rowNew = MonTableau.Rows.Add
 rowNew.Height = MillimetersToPoints(1.5)
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,3,5
            For x = 1 To 5 Step 2
                '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

Le principe :
- On choisit le répertoire où se trouve les photos et le type de fichier.
- On boucle sur les fichiers Photos.
- On Cherche dans le premier tableau, la première cellule libre sur la ligne des images (apparemment tu as des séries de 3 lignes, 1 ligne de photos, 1 ligne de descriptifs, 1 ligne de séparation). On insère la photo en cours dans la première cellule photo libre.
- Si on ne trouve pas de cellules photos disponibles, on crée une nouvelle série de lignes et on insère la photo dans la première cellule photo des nouvelles lignes.

Attention pour que la macro fonctionne, il faut qu'il y ait dans le tableau un multiple de 3 lignes au départ (3 ou 6 ou 9 etc ....) ordonnées comme indiqué précédemment. Sinon il y a un risque de création de lignes non désirées.
Dans ce cas pour éviter le bouclage infini mettre un point d'arrêt sur l'appel de la fonction CréerNewLgTableau tant que la macro n'est pas complétement testée.

Il y a moyen d'optimiser le code (par exemple ne pas rebalayer toutes les cellules à chaque insertion de photos). Cela n'est pas forcément nécessaire si tu n'a pas énormément de photos dans ton document.

Ami calmant, J.P

[dadoo99]

Bonjour Jurassik Pork,

J'ai le même problème que Brutalis, mais le format de mon tableau n'est pas le même. J'ai bien essayer de modifier le code que tu as fait, mais comme je suis une pive en vba, je n'y suis pas arrivé .

Voici mon tableau de photo avec quelques précisions :

• Hauteur photo mode paysage et mode portrait = 5 cm
• Deux colonnes
• Pour les lignes, 1 photo, 1 description, 1 photo, 1 description, etc. (sans ligne de séparation)

De plus, à la place d'insérer le mot "Description" sur les lignes des description, je souhaiterais insérer le nom de l'image sans l'extention.

Photos ext. et int..docx

Merci d'avance pour ton aide.

Dadoo