Insertion et generation photos+legendes

Fermé

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015 - 17 janv. 2015 à 16:34
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 - 21 janv. 2015 à 08:24

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

A voir également:

Insertion et generation photos+legendes
Partage de photos - Guide
Toutes mes photos - Guide
Insertion liste déroulante excel - Guide
Insertion sommaire word - Guide
Doublons photos - Guide

14 réponses

Réponse 1 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
17 janv. 2015 à 17:14

J'ai fait un programme il y a quelques temps:

https://codes-sources.commentcamarche.net/source/53718-planche-contact-sous-word

Réponse 2 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
17 janv. 2015 à 17:43

Voir sur ce site un plus récent:

http://www.cjoint.com/data3/3ArrZpvb3K9.htm

Réponse 3 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
17 janv. 2015 à 17:56

Nouveau lien, ne pas tenir compte du précédent

http://www.cjoint.com/data3/3Arseu9i6GY.htm

Réponse 4 / 14

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015
Modifié par pijaku le 20/01/2015 à 13:22

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

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
19 janv. 2015 à 20:47

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

Réponse 6 / 14

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015
19 janv. 2015 à 21:06

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

Réponse 7 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
20 janv. 2015 à 08:19

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

Réponse 8 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
20 janv. 2015 à 12:03

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

Réponse 9 / 14

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015
20 janv. 2015 à 18:36

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

Réponse 10 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
20 janv. 2015 à 18:42

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é ?

Réponse 11 / 14

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015
Modifié par cats310 le 20/01/2015 à 19:37

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 ??

Réponse 12 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
20 janv. 2015 à 19:57

Pour enregistrer

Cliquez sur le logo en haut à gauche

Enregistrer sous

Document Word 97-2003

Réponse 13 / 14

cats310 Messages postés 6 Date d'inscription samedi 17 janvier 2015 Statut Membre Dernière intervention 20 janvier 2015
20 janv. 2015 à 21:26

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

Réponse 14 / 14

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
21 janv. 2015 à 08:24

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

Discussions similaires

Ne pas voir sur le fil d'actualité mon identification

Discussions similaires

Newsletters