insertion et generation photos+legendes Fermé

Question

Bonjour

Je recherche partout une macro SOUS WORD me permettant : 

1- d'ouvrir un dossier comprenant X photos
2- puis permettre de selectionner toutes les photos avec Control A
2- faire une boucle pour que chaque photo du dossier soit insérée avec création d'une légende numérotée automatiquement

Pour info je suis novice en vba, j'ai tout de même réussi à créer une "petite" macro qui génère l'insertion :

- d'une première photo avec sa légende (choix de la photo prédéfinie)

- une deuxième photo avec la légende (idem choix de la photo)

Besoin d'aide merci 
a vous lire
Cordialement
Cats310

cs_Le Pivert · Answer

J'ai fait un programme il y a quelques temps:

https://codes-sources.commentcamarche.net/source/53718-planche-contact-sous-word

cs_Le Pivert · Answer

Voir sur ce site un plus récent:

 http://www.cjoint.com/data3/3ArrZpvb3K9.htm

cs_Le Pivert · Answer

Nouveau lien, ne pas tenir compte du précédent

http://www.cjoint.com/data3/3Arseu9i6GY.htm

cats310 · Answer

Bonjour

Merci mais cela ne correspond pas vraiment à ce que je recherche...

J'ai bien progressé mais là je bloque au 3/4 de la macro ci-dessous :

Sub AutoNew()
 '
 'InsertionImageLégende Macro
 'Permet l'insertion d'une image avec une légende automatique et groupée
 '

'Sélectionnons notre image
Selection.EndKey Unit:=wdStory
 Dim pict As Shape
 Dim path As Variant
 Dim test As Integer
 With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Filters.Clear
    .Filters.Add "Toutes les images (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg)", "*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.cgm; *.eps; *.pct; *.pict; *.wpg", 1
    .Show
    
       For test = .SelectedItems.Count To 1 Step -1
       path = .SelectedItems(test)
       
       'Insérons notre image
       Set pict = ActiveDocument.Shapes.AddPicture(path)
       pict.Select
       pict.ZOrder msoBringInFrontOfText 'Mise en forme devant le texte pour le groupage
       'Alignement par rapport au paragraphe dans lequel le curseur clignote
       'pict.Top = 0
       'pict.Left = 0
       'Recherche du nom de l'image : on prend la chaîne de caractères située après le dernier "\"
       Dim name As String
       Dim i As Integer
       i = Len(path)
       Do While Not (Mid(path, i, 1) = "\") And i > 0
       i = i - 1
       Loop
       path = Mid(path, i + 1, Len(path) - i)
       'Le nom trouvé est mis dans la zone de texte en tant que légende
       Selection.InsertCaption Label:=" ", Title:=" " '<== Débogage ICI
       Dim LastShape As Integer
       LastShape = ActiveDocument.Shapes.Count
       ActiveDocument.Shapes(LastShape).Select
       'Texte centré
       Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
       'Groupage de l'image et de la zone de texte
       pict.name = path
       ActiveDocument.Shapes(LastShape).name = "caption : " + path
       ActiveDocument.Shapes.Range(Array(path, "caption : " + path)).Group.ConvertToInlineShape
       Next
 End With

End Sub

arrivé à la ligne signalée message "débogage"
Je suis perdue 

pouvez vous m'aider ?
a bientôt j'espère
Cats310

cs_Le Pivert · Answer

Je t'ai transmis ces liens pour que tu puisses les étudier. Dedans tu trouveras une macro pour ajouter un titre à ton image, a toi de l'adapter:


 'ajouter nom du fichier
Sub ajout_text()
fichiersansext = Left(fichierseul, Len(fichierseul) - 4)
 CaptionLabels.Add Name:="Image" 'choisissez le nom que vous désirez
ActiveDocument.InlineShapes(image).Range.InsertCaption _
    Label:="Image", _
    Title:=": " & fichiersansext, Position:=wdCaptionPositionAbove ', ExcludeLabel:=1 'supprime le label reste numero
End Sub

cats310 · Answer

Bonsoir

Merci pour ta rapidité ...mais cela ne m'aide pas beaucoup

La macro transmise précédemment fonctionnait trés bien avant seulement je ne sais pas où est le bug aujourd'hui

cs_Le Pivert · Answer

Voici le code corrigé:

Sub insertimage()
'InsertionImageLégende Macro
 'Permet l'insertion d'une image avec une légende automatique et groupée
 Dim name As String
 Dim i As Integer
 Dim LastShape As Integer
 Dim posit, fichierseul

'Sélectionnons notre image
Selection.EndKey Unit:=wdStory
 Dim pict As Shape
 Dim path As Variant
 Dim test As Integer
 With Application.FileDialog(msoFileDialogOpen)
 .AllowMultiSelect = True
 .Filters.Clear
 .Filters.Add "Toutes les images (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg)", "*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.cgm; *.eps; *.pct; *.pict; *.wpg", 1
 .Show
 For test = .SelectedItems.Count To 1 Step -1
 path = .SelectedItems(test)
     'Recherche du nom de l'image : on prend la chaîne de caractères située après le dernier "\"
       Do
        posit = InStr(1, path, "\")
        path = Right(path, Len(path) - posit)
                Loop Until posit = 0
    fichierseul = path
 'Insérons notre image
 Set pict = ActiveDocument.Shapes.AddPicture(path)
 pict.Select
 pict.ZOrder msoBringInFrontOfText 'Mise en forme devant le texte pour le groupage
 'Alignement par rapport au paragraphe dans lequel le curseur clignote
 pict.Top = 20 'on descend l'image
 pict.Left = 0
 'nom sans l'extension
 name = Left(fichierseul, Len(fichierseul) - 4)
'Le nom trouvé est mis dans la zone de texte en tant que légende
Selection.Collapse Direction:=wdCollapseStart
Selection.InsertCaption Label:="Image", _
Title:=": " & name, Position:=wdCaptionPositionAbove
 LastShape = ActiveDocument.Shapes.Count
 ActiveDocument.Shapes(LastShape).Select
 'Texte centré
 Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
 'Groupage de l'image et de la zone de texte
 pict.name = path
 ActiveDocument.Shapes(LastShape).name = "caption : " + path
 'ActiveDocument.Shapes.Range(Array(path, "caption : " + path)).Group.ConvertToInlineShape
 Next
 End With
End Sub
 

Un petit conseil, tu sélectionnes : InsertCaption et tu appuies sur F1, tu auras ton code

cs_Le Pivert · Answer

Une autre manière de procéder avec la légende sous l'image au quelle on a ajouté la date courante.:

Sub insertimage()
 'Permet l'insertion d'une image avec une légende automatique et groupée
 Dim name As String
 Dim i As Integer
 Dim posit, fichierseul
 Dim path As Variant
 Dim test As Integer
 With Application.FileDialog(msoFileDialogOpen)
 .AllowMultiSelect = True
 .Filters.Clear
 .Filters.Add "Toutes les images (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg)", "*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.cgm; *.eps; *.pct; *.pict; *.wpg", 1
 .Show
 For test = .SelectedItems.Count To 1 Step -1
  path = .SelectedItems(test)
  Next
 End With
 If path = "" Then Exit Sub' si annulation
  'Insérons notre image
 Selection.InlineShapes.AddPicture FileName:=path, LinkToFile:=False, SaveWithDocument:=True
 i = ActiveDocument.InlineShapes.Count 'nbre d'images
 'redimensionnement des images a activer si necessaire
'With ActiveDocument.InlineShapes(i)
  '  .ScaleHeight = 30
  '  .ScaleWidth = 30
'End With
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'centrer l'image
Selection.ClearFormatting
'Recherche du nom de l'image : on prend la chaîne de caractères située après le dernier "\"
       Do
        posit = InStr(1, path, "\")
        path = Right(path, Len(path) - posit)
                Loop Until posit = 0
    fichierseul = path
     'nom sans l'extension
 name = Left(fichierseul, Len(fichierseul) - 4)
'Le nom trouvé est mis dans la zone de texte en tant que légende
Selection.Collapse Direction:=wdCollapseStart
Selection.InsertCaption Label:="Image", _
Title:=": " & name & "-", Position:=wdCaptionPositionAbove
InsertDateTimeMethod
End Sub
'http://support.microsoft.com/kb/212682/fr
Sub InsertDateTimeMethod()
   Dim MyRange As Object
   Set MyRange = Selection.Range
   MyRange.InsertDateTime DateTimeFormat:="dd MMM yyyy", _
   InsertAsField:=True
 End Sub

Voir le lien pour les ajouts de texte

cats310 · Answer

Bonjour

Merci pour les infos :

de mon coté 

Sub AutoNew()
 '
 'InsertionImageLégende Macro
 'Permet l'insertion d'une image avec une légende automatique et groupée
 '

 'Sélectionnons notre image
Selection.EndKey Unit:=wdStory
 Dim pict As Shape
 Dim path As Variant
 Dim test As Integer
 With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Filters.Clear
    .Filters.Add "Toutes les images (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg)", "*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.cgm; *.eps; *.pct; *.pict; *.wpg", 1
    .Show
    
       For test = .SelectedItems.Count To 1 Step -1
       path = .SelectedItems(test)
       
       'Insérons notre image
       Set pict = ActiveDocument.Shapes.AddPicture(path)
       pict.Select
       pict.ZOrder msoBringInFrontOfText 'Mise en forme devant le texte pour le groupage
       'Alignement par rapport au paragraphe dans lequel le curseur clignote
       'pict.Top = 0
       'pict.Left = 0
       'Recherche du nom de l'image : on prend la chaîne de caractères située après le dernier "\"
       Dim name As String
       Dim i As Integer
       i = Len(path)
       Do While Not (Mid(path, i, 1) = "\") And i > 0
       i = i - 1
       Loop
       path = Mid(path, i + 1, Len(path) - i)
       'Le nom trouvé est mis dans la zone de texte en tant que légende
       With CaptionLabels("image")
        .NumberStyle = wdCaptionNumberStyleArabic
        .IncludeChapterNumber = False
    End With
    Selection.InsertCaption Label:="image", TitleAutoText:= _
        "InsertionLégende10", Title:="", Position:=wdCaptionPositionBelow, _
        ExcludeLabel:=1
       Dim LastShape As Integer
       LastShape = ActiveDocument.Shapes.Count
       ActiveDocument.Shapes(LastShape).Select
       'Texte centré
       Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
       'Groupage de l'image et de la zone de texte
       pict.name = path
       ActiveDocument.Shapes(LastShape).name = "caption : " + path
       ActiveDocument.Shapes.Range(Array(path, "caption : " + path)).Group.ConvertToInlineShape
       Next
 End With
 
 
 End Sub


cette macro fonctionne super bien sur word 2013 (maison) mais pas sur word 2010 (bureau)... grrrrrr....why 

besoin urgent au bureau en fait donc word 2010
merci de votre aide

cs_Le Pivert · Answer

Je suis avec Word 2007, donc de ce côté là, je ne peux pas faire d'essai.

Tu peux essayer de les enregistrer sous Word 97-2003

 As-tu essayé les 2 procédures que je t'ai donné ?

cats310 · Answer

je les ai tentées sur word 2013 mais elles ne fonctionnent pas, je ne pourrai les tester que demain sur 2010....

à défaut comment faut-il faire pour enregistrer celle qui fonctionne sur 2013 en format 97-2003 seulement en cochant la case mode de compatibilité avec versions précédentes ??

cs_Le Pivert · Answer

Pour enregistrer 

Cliquez sur le logo en haut à gauche

Enregistrer sous

Document Word 97-2003

cats310 · Answer

merci je tente demain, au bureau  et vous tiens au courant
bonsoir

cs_Le Pivert · Answer

Chez moi sous Word 2007, j'ai  une erreur ici:

Selection.InsertCaption Label:="image", TitleAutoText:= _ 
 "InsertionLégende10", Title:="", Position:=wdCaptionPositionBelow, _ 
 ExcludeLabel:=1 

d'autre part tu recherches la variable name, mais tu ne l'utilises pas

Insertion et generation photos+legendes

14 réponses

Discussions similaires