Bonjour à tous,

Je bloque sur un truc depuis quelque jours et j'ai pas mal cherché comment je pourrais faire avant de poser la question: je souhaiterais créer une macro
qui insère une zone de texte avec fond rouge et une flèche (forme accolée) sur chaque photo de mon rapport: ceci afin d'éviter les copier coller lorsque j'ai 100
photos dans mon rapport...

Je remercie d'avance les personne qui accepterons de m'aider dans ma démarche.

Ci- joint les maccro que j'utilise déjà et qui pourront peut-être être utile à d'autres.

Bonne journée.


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
73
74
75
76
 Sub InsertionImages()
 
Dim Repertoire As String
Dim Extension As String
Dim Fichier As String
 
 Dim objShell As Object, objFolder As Object, oFolderItem As Object 'Pour répertoire
Dim Chemin As String, Nom As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Vous êtes sur le point d'importer des photos dans le rapport. Spécifiez le répertoire de fichier image à utiliser", &H1&)
   On Error Resume Next
   Set oFolderItem = objFolder.Items.Item
   Chemin = oFolderItem.Path
   'Si pas de répertoire ou sous-répertoire sélectionné alors on sort...
  If Chemin = "" Then Exit Sub
 
'Saisie du nom du répertoire
Repertoire = InputBox("Spécifiez le répertoire de fichier images à utiliser", "Répertoire", Chemin & "\")
'Saisie du type d'extension
Extension = InputBox("Type de fichier à utiliser ", "Type de fichier", "jpg")
 
'Récupération du premier fichier du répertoire
Fichier = Dir(Repertoire & "*" & Extension, vbDirectory)
 
Do While Fichier <> ""
    i = i + 1
 
    'Insertion de l'image
    Selection.InlineShapes.AddPicture FileName:=Repertoire & Fichier
 
 
    'Insertion d'une ligne vide
    Selection.TypeParagraph
    'changer l'écriture
 
        With Selection.Font
        .Name = "Century Gothic"
        .Underline = wdUnderlineSingle
        .Bold = True
        .Size = 10
        End With
 
 
    Selection.TypeText ("Photo " & i & "Titre ")
    Selection.TypeParagraph
 
    'Récupération du prochain fichier du répertoire
    Fichier = Dir
    Selection.Next
Loop
 
End Sub
Sub redimimages()
'Déclaration des variables
Dim oISh As InlineShape 'variable objet représentant un objet image
'Boucle sur toutes les images du document
For Each oISh In ActiveDocument.InlineShapes
    'Sélection de l'image
    'Important pour déterminer si l'image se trouve dans une cellule de tableau
    oISh.Select
    'Test sur la position de l'image
    If Selection.Information(wdWithInTable) Then
        'Si l'image est dans une cellule on la redimentionne
        With oISh
            'affectation des dimensions de l'image
            'On convertit des centimètres en points
            .Height = CentimetersToPoints(11.01)
            .Width = CentimetersToPoints(14.76)
 
 
        End With
    End If
Next oISh
 
 
End Sub