Discussion :

[RICKMOSA]

EDIT : DESOLE SI LE POST N'EST PAS DANS LA BONNE CATEGORIE OU MAL INTITULE

Bonjour
je suis en train de créer un tableau dans lequel je souhaite insérer des images gif depuis un dossier.
Le tableau comporte 660 cellules et je voudrais insérer une image dans chaque cellule par le biais d'une macro car une par une ca fait un peu long
J'aimerais également dans l'idéal insérer une légende correspondant a chaque image. Chaque légende est présente dans une liste dans un fichier texte.
Je suis novice en macro et voila ce que j'ai réussi a trouver jusque la
Je suis sur Word 15.13.3 sur un macbook pro de 2011 sous OSX 10.12.6

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
 
Sub Macro1()
'
' Macro1 Macro
'
'
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/1.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/2.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/3.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveLeft Unit:=wdCharacter, Count:=5
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/4.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/5.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/6.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveLeft Unit:=wdCharacter, Count:=5
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/7.gif", LinkToFile:=False, _
        SaveWithDocument:=True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture fileName:= _
        "/Users/gapgang/Desktop/GIF POKMN/8.gif", LinkToFile:=False, _
        SaveWithDocument:=True
End Sub

Ceci n'est qu'un extrait je suis obligé de répéter une boucle par image
J'aimerais automatiser la selection d'image une après l'autre
A ce niveau lorsque j'éxécute la macro on me demande d'accorder l'accès a chaque image ce qui fait perdre du temps.

Pourriez vous m'aider a modifier ce code pour une selection auto des images avec ajout de la légende en "piochant" le mot clé dans mon fichier texte ? Si c'est réalisable ?

Merci par avance

Rick

[RICKMOSA]

Bonjour

Est ce que mon opération est irréalisable ?
Je précise que j'ai cherché depuis une semaine sur différents site ainsi que sur votre forum sans succès mais désolé si ce sujet a déja été solutionné
Enfin dernière précision le code que je présente est un code généré par enregistrement de macro sur word puis j'ai modifié le chemin d'accès pour les images et j'ai copié la boucle. Peut être y a t il plus simple ?

J'éspère que vous pourrez m'aider

Cordialement

Rick

[Philippe Tulliez]

Bonjour,

Enfin dernière précision le code que je présente est un code généré par enregistrement de macro sur word puis j'ai modifié le chemin d'accès pour les images et j'ai copié la boucle. Peut être y a t il plus simple ?

Je ne vois pas de boucle dans la procédure que vous avez publiée
Quel est votre problème exactement ?

[RICKMOSA]

Bonjour
Merci pour votre réponse
Je m’exprime peut être mal effectivement il n’y a pas de «*loop*» je parle de boucle car je répète l’opération «*sélection de l’image puis déplacement entre les cellule*»
Mon problème est que pour les 660 images je suis obligé de copier l’opération pour chaque image. De plus on me demande l’autorisation d’accès à chaque image lorsque la macro est exécutée.

Je souhaiterais une macro qui automatise la sélection d’image en les plaçant dans les cellule les une après les autres.
Et ensuite une macro pour insérer un mot dans chaque cellule correspondant à l’image. Les mots sont dans une liste numérotés de 1 à 660 dans un fichier texte.

Je sais pas si c’est clair.

Merci pour votre aide

Cordialement

[Philippe Tulliez]

Bonjour,
Alors voici une procédure nommée InsertImagesInTable qui insère les images présentes dans un répertoire dédié dans les cellules d'un tableau (pour l'exemple c'est le premier tableau du document)

Cette procédure en invoque deux

1. GetFileList qui charge la liste de tous les fichiers présents (voir mon billet VBA/Excel - Fonction qui renvoie la liste des fichiers d'un répertoire en fonction d'un critère)
2. AdjustImageSize qui ajuste la hauteur et la largeur des images (voir code plus bas)

Dans mon exemple, le tableau est déjà créé avec suffisamment de cellules.

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
Sub InsertImagesInTable()
  ' Insere les images dans une table
  Const FolderPath As String = "C:\Users\toto\Desktop\Images\Pictogrammes\"
  Const Height As Double = 100 ' Hauteur de l'image
  Const Width As Double = 100  ' Largeur de l'image
  Dim FileArray() As Variant
  Dim Table As Table
  Dim RowIndex As Integer, ColIndex As Integer
  Dim ImageIndex As Integer
  Dim ImagePath As String
  ' On suppose que le tableau dans lequel on insère les images est le premier tableau du document
  Set Table = ActiveDocument.Tables(1)
  ' Récupère la liste des images présents dans le répertoire définit par la constante FolderPath  
  FileArray = GetFileList(FolderPath & "*.*")
 ' S'il y a au moins un fichier trouvé 
 If IsArray(FileArray) Then
    ImageIndex = LBound(FileArray) ' Commencer avec la première image
    For RowIndex = 1 To Table.Rows.Count
      For ColIndex = 1 To Table.Rows(RowIndex).Cells.Count
        If ImageIndex <= UBound(FileArray) Then
          ' Définir le chemin complet de l'image
          ImagePath = FolderPath & FileArray(ImageIndex)
          ' Insérer l'image dans la cellule actuelle
          With Table.Rows(RowIndex).Cells(ColIndex).Range
          .InlineShapes.AddPicture FileName:=ImagePath, LinkToFile:=False, SaveWithDocument:=True
           ' Ajuster la taille de l'image juste après son insertion
           AdjustImageSize .InlineShapes(1), TargetWidth:=Width, TargetHeight:=Height ' Remplacez 100 par la largeur et la hauteur souhaitées
          End With
          ' Passer à l'image suivante
          ImageIndex = ImageIndex + 1
        End If
      Next
    Next
  End If
  Set Table = Nothing
End Sub

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
Sub AdjustImageSize(InlineShape As InlineShape, TargetWidth As Single, TargetHeight As Single)
  '  Ajuste la taille de l'image
  Dim AspectRatio As Single
  ' Calculer le ratio de l'image
  AspectRatio = InlineShape.Width / InlineShape.Height
  ' Ajuster par la largeur ou la hauteur en fonction du ratio
  If AspectRatio >= 1 Then ' L'image est plus large que haute
    If InlineShape.Width > TargetWidth Then
      InlineShape.Width = TargetWidth
      InlineShape.Height = TargetWidth / AspectRatio
    End If
  Else ' L'image est plus haute que large
    If InlineShape.Height > TargetHeight Then
      InlineShape.Height = TargetHeight
      InlineShape.Width = TargetHeight * AspectRatio
    End If
  End If
End Sub

[RICKMOSA]

Bonjour

Tout d'abord merci beaucoup de prendre le temps de me répondre avec autant de précision

Je viens de tester le premier code et voici le message que ça me renvoit :



J'ai uniquement modifié le chemin d'accès aux images

Sauriez vous me dire quelle est la problématique ?

PS: LA CAPTURE OPEN OFFICE EST UNE ERREUR DE MA PART

Merci encore

Cordialement

[Philippe Tulliez]

Bonjour,
C'est très curieux. J'ai testé mon code avant de le publier et il a tourné au moins cinq fois.
Ma version est Office 365 et en regardant mieux votre image, je constate que vous êtes sur un Mac. Peut-être que cet objet chez eux porte un autre nom ?

Il faudrait créer un tableau avec l'enregistreur de macros pour vérifier le type d'objet qui est utilisé.

Voilà le code que l'enregistreur m'a donné

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
Sub Macro4()
'
' Macro4 Macro
'
'
 ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=8, NumColumns:= _
  3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
  wdAutoFitFixed
 With Selection.Tables(1)
  If .Style <> "Grille du tableau" Then
   .Style = "Grille du tableau"
  End If
  .ApplyStyleHeadingRows = True
  .ApplyStyleLastRow = False
  .ApplyStyleFirstColumn = True
  .ApplyStyleLastColumn = False
  .ApplyStyleRowBands = True
  .ApplyStyleColumnBands = False
 End With
End Sub

[RICKMOSA]

Bonjour

Encore merci

Voici le code généré par l'enregistrement Macro sur la création d'un tableau

Je n'y comprend pas grand chose

Code :

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

1
2
3
4
5
6
7
8
9
10
 
Sub Macro2()
'
' Macro2 Macro
'
'
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:= _
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
End Sub

Merci a vous
Cordialement

[Philippe Tulliez]

Bonjour,
Donc manifestement, c'est le même objet.
Peut-être le message d'erreur renvoyé n'est pas le bon. Une idée serait que l'on ne pourrait pas utiliser un nom d'objet comme variable

Bien que cela fonctionne chez moi, tentons en modifiant le nom de la variable Table par oTable pour éviter toute ambiguïté

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
Sub InsertImagesInTable()
  ' Insere les images dans une table
  Const FolderPath As String = "C:\Users\toto\Desktop\Images\Pictogrammes\"
  Const Height As Double = 100 ' Hauteur de l'image
  Const Width As Double = 100  ' Largeur de l'image
  Dim FileArray() As Variant
  Dim oTable As Table
  Dim RowIndex As Integer, ColIndex As Integer
  Dim ImageIndex As Integer
  Dim ImagePath As String
  ' Supposons que le tableau dans lequel vous souhaitez insérer des images est le premier tableau du document
  Set oTable = ActiveDocument.Tables(1)
  ' Récupérer la liste des images
  FileArray = GetFileList(FolderPath & "*.*")
  If IsArray(FileArray) Then
    ImageIndex = LBound(FileArray) ' Commencer avec la première image
    For RowIndex = 1 To oTable.Rows.Count
      For ColIndex = 1 To oTable.Rows(RowIndex).Cells.Count
        If ImageIndex <= UBound(FileArray) Then
          ' Définir le chemin complet de l'image
          ImagePath = FolderPath & FileArray(ImageIndex)
          ' Insérer l'image dans la cellule actuelle
          With oTable.Rows(RowIndex).Cells(ColIndex).Range
          .InlineShapes.AddPicture FileName:=ImagePath, LinkToFile:=False, SaveWithDocument:=True
           ' Ajuster la taille de l'image juste après son insertion
           AdjustImageSize .InlineShapes(1), TargetWidth:=Width, TargetHeight:=Height ' Remplacez 100 par la largeur et la hauteur souhaitées
          End With
          ' Passer à l'image suivante
          ImageIndex = ImageIndex + 1
        End If
      Next
    Next
  End If
  Set oTable = Nothing
End Sub

[RICKMOSA]

Bonjour

Je viens a nouveau de tester avec les modifications et une nouvelle erreur s'affiche.

De plus j'ai un soucis d'affichage sur mon virtual basic editor qui fait que je ne peux pas vraiment lire d'ou provient l'erreur

En pj mon affichage VBE et le message d'erreur

Je ne comprend pas ... y a t il d'autre choses que je dois modifier ? Un nom de fichier ou autre quelque part autre que le chemin d'accès ?

Merci encore




Cordialement

[Philippe Tulliez]

Bonjour,
Sans visualiser la ligne qui est en erreur c'est difficile de pouvoir apporter une réponse pertinente.
Il faudrait mettre des "Break Point" à différents endroits du code (voir le chapitre II-B-3-d. Les points d'arrêt du tutoriel Vos premiers pas dans l'éditeur de macros Excel
Est-ce que les deux procédures GetFileList et AdjustImageSize sont bien présentes ?

Pour bien appréhender l'éditeur VBA et comprendre le débogage en VBA, je conseille la lecture de ces tutoriels

• Vos premiers pas dans l'éditeur de macros Excel
• Le débogage sous Visual Basic 6 et Visual Basic pour Application(1re partie)
• Le débogage sous Visual Basic 6 et Visual Basic pour Application (2e partie)

[RICKMOSA]

Bonjour

Merci encore

J'ai obtenu une nouvelle version de word qui corrige le problème d'affichage

Je vous met en pj ce qui apparait lorsque j'éxécute le code

Je vais me pencher sur les liens que vous m'avez transféré

Cordialement

[Philippe Tulliez]

Bonjour,
Est-ce vous avez copié la procédure GetFileList ?
Ne pas oublier de placer les points d'arrêt (F9) et utiliser l'exécution "pas à pas" (F8) pour localiser les problèmes.
Je rappelle que sur la version Windows la procédure fonctionne parfaitement.

[RICKMOSA]

Bonjour
Je suis désolé j'ai clairement raté cette étape
et je ne comprend pas ou je dois insérer la procédure GetFileList..
Est ce que je dois l’exécuter au préalable ? Ou l'insérer dans le code complet ?
Merci encore pour votre temps

Cordialement

[Philippe Tulliez]

Bonjour,
En regardant mieux votre illustration, je constate également que vous n'avez pas placé les procédures dans un module standard. ThisDocument ne devrait contenir que des procédures événementielles.
Les procédures se placent dans un module standard. Il suffit donc de copier GetFileList et le placer dans le même module standard que les autres procédures.

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
Function GetFileList(ByVal LookUpFullName As String) As Variant
  ' Renvoie une liste des fichiers présents dans le répertoire défini pas l'argument LookUpFullName
  '     Les caractères génériques (*, ?) 
  ' Philippe Tulliez (http://www.magicoffice.be)
  ' Arguments
  '   LookUpFullName (String) Répertoire complet + nom du fichier partiel ou pas + éventuellement extension
  '
  Dim f As String, c As Integer, t As Variant
  f = Dir(LookUpFullName)
  Do While Len(f)
    If c Then ReDim Preserve t(c) Else ReDim t(c)
    t(c) = f: c = c + 1: f = Dir
  Loop
  GetFileList = t
End Function

[EDIT]
Pour insérer un module, il faut aller dans le menu Insertion, voir ci-dessous, et ensuite enlever les procédures de ThisDocument pour les placer dans le module standard et idéalement le renommer.

Illustration

[RICKMOSA]

Bonjour

Merci pour vos précisions

Je découvre vraiment le VBA donc je me creuse un peu la tête avec ce que vous me donnez
Je vais tenter de déjà m'en sortir avec tout ça je reviens vers vous dès que (j’espère) j'aurais réussi

Cordialement

[RICKMOSA]

Bonjour

J'ai intégré les procédures GetFileList et AdjustImageSize dans des modules comme vous me l'avez expliqué.
Je parviens à exécuter la macro mais je fais face à plusieurs problèmes :

- Une seule image est insérée dans le tableau dans la première case et la macro s'arrête.
- Pour chaque image une autorisation d'accès est demandée

Je souhaiterais ajuster la taille des images et faire en sorte d'avoir 1 image par page, soit 1 cellule par page, mon tableau étant créé avec 1 colonne pour 700 ligne. J'ai déja grandement augmenté la taille dans le code mais je pense que ca n'est pas la bonne marche à suivre.

Et surtout j'aimerais que la boucle s'effectue et que toutes les images s'ajoutent dans le tableau comme la première, sans avoir a valider l'accès pour chaque image.

Je touche au but mais j'ai encore besoin de votre aide pour résoudre ces derniers problèmes...

Ci dessous le code tel que je l'exécute :

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
Option Explicit
Sub InsertImagesInTable()
  ' Insere les images dans une table
  Const FolderPath As String = "/Users/gapgang/Desktop/GIFPOKMN/"
  Const Height As Double = 99999999 ' Hauteur de l'image
  Const Width As Double = 9999999  ' Largeur de l'image
  Dim FileArray() As Variant
  Dim oTable As Table
  Dim RowIndex As Integer, ColIndex As Integer
  Dim ImageIndex As Integer
  Dim ImagePath As String
  ' Supposons que le tableau dans lequel vous souhaitez insérer des images est le premier tableau du document
  Set oTable = ActiveDocument.Tables(1)
  ' Récupérer la liste des images
  FileArray = GetFileList(FolderPath & "*.*")
  If IsArray(FileArray) Then
    ImageIndex = LBound(FileArray) ' Commencer avec la première image
    For RowIndex = 1 To oTable.Rows.Count
      For ColIndex = 1 To oTable.Rows(RowIndex).Cells.Count
        If ImageIndex <= UBound(FileArray) Then
          ' Définir le chemin complet de l'image
          ImagePath = FolderPath & FileArray(ImageIndex)
          ' Insérer l'image dans la cellule actuelle
          With oTable.Rows(RowIndex).Cells(ColIndex).Range
          .InlineShapes.AddPicture FileName:=ImagePath, LinkToFile:=False, SaveWithDocument:=True
           ' Ajuster la taille de l'image juste après son insertion
           AdjustImageSize .InlineShapes(1), TargetWidth:=Width, TargetHeight:=Height ' Remplacez 100 par la largeur et la hauteur souhaitées
          End With
          ' Passer à l'image suivante
          ImageIndex = ImageIndex + 1
        End If
      Next
    Next
  End If
  Set oTable = Nothing
End Sub
 
Function GetFileList(ByVal LookUpFullName As String) As Variant
  ' Renvoie une liste des fichiers présents dans le répertoire défini pas l'argument LookUpFullName
  '     Les caractères génériques (*, ?)
  ' Philippe Tulliez (http://www.magicoffice.be)
  ' Arguments
  '   LookUpFullName (String) Répertoire complet + nom du fichier partiel ou pas + éventuellement extension
  '
  Dim f As String, c As Integer, t As Variant
  f = Dir(LookUpFullName)
  Do While Len(f)
    If c Then ReDim Preserve t(c) Else ReDim t(c)
    t(c) = f: c = c + 1: f = Dir
  Loop
  GetFileList = t
End Function
 
 
Sub AdjustImageSize(InlineShape As InlineShape, TargetWidth As Single, TargetHeight As Single)
  '  Ajuste la taille de l'image
  Dim AspectRatio As Single
  ' Calculer le ratio de l'image
  AspectRatio = InlineShape.Width / InlineShape.Height
  ' Ajuster par la largeur ou la hauteur en fonction du ratio
  If AspectRatio >= 1 Then ' L'image est plus large que haute
    If InlineShape.Width > TargetWidth Then
      InlineShape.Width = TargetWidth
      InlineShape.Height = TargetWidth / AspectRatio
    End If
  Else ' L'image est plus haute que large
    If InlineShape.Height > TargetHeight Then
      InlineShape.Height = TargetHeight
      InlineShape.Width = TargetHeight * AspectRatio
    End If
  End If
End Sub

Et en pj le message pour octroyer l'accès aux images.

Merci encore pour votre aide

Cordialement

[Philippe Tulliez]

Bonjour,
A ce stade, j'avoue que je ne vois pas ce que je peux ajouter car chez moi, cela fonctionne parfaitement. Je lance la procédure et toutes les images sont intégrées.
La compatibilité entre Mac et Windows n'est pas parfaite surtout avec le VBA et comme je n'ai pas de Mac, il m'est difficile d'aller plus loin.
A l'aveugle, je tenterais ceci. Dans la procédure nommée InsertImagesInTable, mettez les trois premières lignes ci-dessous juste après les lignes de déclarations des variables (la suite de Dim) et la dernière ligne "Application.DisplayAlerts = statDisplayAlert" à la fin de cette procédure, juste avant l'instruction Set oTable = Nothing

Code :

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

1
2
3
4
5
Dim statDisplayAlert As Integer
statDisplayAlert = Application.DisplayAlerts
Application.DisplayAlerts = wdAlertsNone
  ' Le code
Application.DisplayAlerts = statDisplayAlert

[RICKMOSA]

Bonjour
Je me casse toujours la tête mais je perds pas espoir ^^
Je me demandais si vous seriez en mesure de m'aider pour une autre tache sur ce tableau
Je souhaite insérer dans une seule colonne 1 mot par ligne
Les mots sont listés dans un document texte a part
Comment faire pour que la macro prenne les mots 1 à 1 ( chaque ligne commencant par #) et les insère dans 1 seule colonne ligne après ligne ?

Merci

Cordialement